Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

10547 lines (8496 sloc) 311.62 kb
;;============================================================================
;;; File: "_t-univ.scm"
;;; Copyright (c) 2011-2015 by Marc Feeley, All Rights Reserved.
;;; Copyright (c) 2012 by Eric Thivierge, All Rights Reserved.
(include "generic.scm")
(include-adt "_envadt.scm")
(include-adt "_gvmadt.scm")
(include-adt "_ptreeadt.scm")
(include-adt "_sourceadt.scm")
(define univ-enable-jump-destination-inlining? #f)
(set! univ-enable-jump-destination-inlining? #t)
(define univ-dyn-load? #f)
(set! univ-dyn-load? #f)
(define (univ-get-representation-option ctx name)
(let ((x (assq name (ctx-options ctx))))
(and x (pair? (cdr x)) (cadr x))))
(define (univ-procedure-representation ctx)
(or (univ-get-representation-option ctx 'repr-procedure)
(case (target-name (ctx-target ctx))
((php)
'class)
(else
'host))))
(define (univ-null-representation ctx)
(or (univ-get-representation-option ctx 'repr-null)
(case (target-name (ctx-target ctx))
((js)
'host)
(else
'class))))
(define (univ-void-representation ctx)
(or (univ-get-representation-option ctx 'repr-void)
'host))
(define (univ-eof-representation ctx)
'class)
(define (univ-absent-representation ctx)
'class)
(define (univ-unbound-representation ctx)
'class)
(define (univ-optional-representation ctx)
'class)
(define (univ-key-representation ctx)
'class)
(define (univ-rest-representation ctx)
'class)
(define (univ-boolean-representation ctx)
(or (univ-get-representation-option ctx 'repr-boolean)
'host))
(define (univ-char-representation ctx)
'class)
(define (univ-fixnum-representation ctx)
(or (univ-get-representation-option ctx 'repr-fixnum)
'host))
(define (univ-flonum-representation ctx)
(or (univ-get-representation-option ctx 'repr-flonum)
'class))
(define (univ-vector-representation ctx)
(or (univ-get-representation-option ctx 'repr-vector)
(case (target-name (ctx-target ctx))
((php)
'class)
(else
'host))))
(define (univ-u8vector-representation ctx)
'class)
(define (univ-u16vector-representation ctx)
'class)
(define (univ-f64vector-representation ctx)
'class)
(define (univ-structure-representation ctx)
'class)
(define (univ-string-representation ctx)
(or (univ-get-representation-option ctx 'repr-string)
'class))
(define (univ-symbol-representation ctx)
(or (univ-get-representation-option ctx 'repr-symbol)
(case (target-name (ctx-target ctx))
((js)
'host) ;; TODO: must be 'class to support uninterned symbols
(else
'class))))
(define (univ-keyword-representation ctx)
'class)
(define (univ-tostr-method-name ctx)
(case (target-name (ctx-target ctx))
((js)
'toString)
((php)
'__toString)
((python)
'__str__)
((ruby)
'to_s)
(else
(compiler-internal-error
"univ-tostr-method-name, unknown target"))))
(define univ-thread-cont-slot 5)
(define univ-thread-denv-slot 6)
(define (univ-php-version-53? ctx)
(assq 'php53 (ctx-options ctx)))
(define (univ-always-return-call? ctx)
(assq 'always-return-call (ctx-options ctx)))
(define (univ-never-return-call? ctx)
(assq 'never-return-call (ctx-options ctx)))
(define univ-tag-bits 2)
(define univ-word-bits 32)
(define univ-fixnum-max+1
(arithmetic-shift 1 (- univ-word-bits (+ 1 univ-tag-bits))))
(define univ-fixnum-max (- univ-fixnum-max+1 1))
(define univ-fixnum-min (- -1 univ-fixnum-max))
(define univ-fixnum-max*2+1 (+ (* univ-fixnum-max 2) 1))
;;;----------------------------------------------------------------------------
;;
;; "Universal" back-end.
;; Initialization/finalization of back-end.
(define (univ-setup target-language file-extensions options)
(define common-options
'((repr-procedure symbol)
(repr-null symbol)
(repr-void symbol)
(repr-boolean symbol)
(repr-fixnum symbol)
(repr-flonum symbol)
(repr-vector symbol)
(repr-string symbol)
(repr-symbol symbol)
(always-return-call)
(never-return-call)))
(let ((targ
(make-target 10
target-language
file-extensions
(append options common-options)
0)))
(define (begin! info-port)
(target-dump-set!
targ
(lambda (procs output c-intf module-descr unique-name options)
(univ-dump targ procs output c-intf module-descr unique-name options)))
(target-nb-regs-set! targ univ-nb-gvm-regs)
(target-prim-info-set!
targ
(lambda (name)
(univ-prim-info targ name)))
(target-label-info-set!
targ
(lambda (nb-parms closed?)
(univ-label-info targ nb-parms closed?)))
(target-jump-info-set!
targ
(lambda (nb-args)
(univ-jump-info targ nb-args)))
(target-frame-constraints-set!
targ
(make-frame-constraints univ-frame-reserve univ-frame-alignment))
(target-proc-result-set!
targ
(make-reg 1))
(target-task-return-set!
targ
(make-reg 0))
(target-switch-testable?-set!
targ
(lambda (obj)
(univ-switch-testable? targ obj)))
(target-eq-testable?-set!
targ
(lambda (obj)
(univ-eq-testable? targ obj)))
(target-object-type-set!
targ
(lambda (obj)
(univ-object-type targ obj)))
#f)
(define (end!)
#f)
(target-begin!-set! targ begin!)
(target-end!-set! targ end!)
(target-add targ)))
(univ-setup 'js '((".js" . JavaScript)) '())
(univ-setup 'python '((".py" . Python)) '())
(univ-setup 'ruby '((".rb" . Ruby)) '())
(univ-setup 'php '((".php" . PHP)) '((php53)))
;;;----------------------------------------------------------------------------
;; Generation of textual target code.
(define (univ-indent . rest)
(cons '$$indent$$ rest))
(define (univ-constant val)
(univ-box val val))
(define (univ-box boxed unboxed)
(list '$$box$$ boxed unboxed))
(define (univ-box? x)
(and (pair? x)
(eq? (car x) '$$box$$)))
(define (univ-unbox x)
(and (univ-box? x)
(cddr x)))
(define (univ-display x port)
(define indent-level 0)
(define after-newline? #t)
(define (indent)
(if after-newline?
(begin
(display (make-string (* 2 indent-level) #\space) port)
(set! after-newline? #f))))
(define (disp x)
(cond ((string? x)
(let loop1 ((i 0))
(let loop2 ((j i))
(define (display-substring limit)
(if (< i limit)
(begin
(indent)
(if (and (= i 0) (= limit (string-length x)))
(display x port)
(display (substring x i limit) port)))))
(if (< j (string-length x))
(let ((c (string-ref x j))
(j+1 (+ j 1)))
(if (char=? c #\newline)
(begin
(display-substring j+1)
(set! after-newline? #t)
(loop1 j+1))
(loop2 j+1)))
(display-substring j)))))
((symbol? x)
(disp (symbol->string x)))
((char? x)
(disp (string x)))
((null? x))
((pair? x)
(case (car x)
(($$indent$$)
(set! indent-level (+ indent-level 1))
(disp (cdr x))
(set! indent-level (- indent-level 1)))
(($$box$$)
(disp (cadr x)))
(else
(disp (car x))
(disp (cdr x)))))
((vector? x)
(disp (vector->list x)))
(else
(indent)
(display x port))))
(disp x))
;;;----------------------------------------------------------------------------
;; ***** PROCEDURE CALLING CONVENTION
(define univ-nb-gvm-regs 5)
(define univ-nb-arg-regs 3)
(define (univ-label-info targ nb-parms closed?)
;; After a GVM "entry-point" or "closure-entry-point" label, the following
;; is true:
;;
;; * return address is in GVM register 0
;;
;; * if nb-parms <= nb-arg-regs
;;
;; then parameter N is in GVM register N
;;
;; else parameter N is in
;; GVM register N-F, if N > F
;; GVM stack slot N, if N <= F
;; where F = nb-parms - nb-arg-regs
;;
;; * for a "closure-entry-point" GVM register nb-arg-regs+1 contains
;; a pointer to the closure object
;;
;; * other GVM registers contain an unspecified value
(let ((nb-stacked (max 0 (- nb-parms univ-nb-arg-regs))))
(define (location-of-parms i)
(if (> i nb-parms)
'()
(cons (cons i
(if (> i nb-stacked)
(make-reg (- i nb-stacked))
(make-stk i)))
(location-of-parms (+ i 1)))))
(let ((x (cons (cons 'return 0) (location-of-parms 1))))
(make-pcontext nb-stacked
(if closed?
(cons (cons 'closure-env
(make-reg (+ univ-nb-arg-regs 1)))
x)
x)))))
(define (univ-jump-info targ nb-args)
;; After a GVM "jump" instruction with argument count, the following
;; is true:
;;
;; * the return address is in GVM register 0
;;
;; * if nb-args <= nb-arg-regs
;;
;; then argument N is in GVM register N
;;
;; else argument N is in
;; GVM register N-F, if N > F
;; GVM stack slot N, if N <= F
;; where F = nb-args - nb-arg-regs
;;
;; * GVM register nb-arg-regs+1 contains a pointer to the closure object
;; if a closure is being jumped to
;;
;; * other GVM registers contain an unspecified value
(let ((nb-stacked (max 0 (- nb-args univ-nb-arg-regs))))
(define (location-of-args i)
(if (> i nb-args)
'()
(cons (cons i
(if (> i nb-stacked)
(make-reg (- i nb-stacked))
(make-stk i)))
(location-of-args (+ i 1)))))
(make-pcontext nb-stacked
(cons (cons 'return (make-reg 0))
(location-of-args 1)))))
;; The frame constraints are defined by the parameters
;; univ-frame-reserve and univ-frame-alignment.
(define univ-frame-reserve 0) ;; no extra slots reserved
(define univ-frame-alignment 1) ;; no alignment constraint
;; ***** PRIMITIVE PROCEDURE DATABASE
(define (univ-prim-info targ name)
(univ-prim-info* name))
(define (univ-prim-info* name)
(table-ref univ-prim-proc-table name #f))
(define univ-prim-proc-table (make-table))
(define (univ-prim-proc-add! x)
(let ((name (string->canonical-symbol (car x))))
(table-set! univ-prim-proc-table
name
(apply make-proc-obj (car x) #f #t #f (cdr x)))))
(for-each univ-prim-proc-add! prim-procs)
(univ-prim-proc-add! '("##inline-host-statement" 1 #t 0 0 (#f) extended))
(univ-prim-proc-add! '("##inline-host-expression" 1 #t 0 0 (#f) extended))
(univ-prim-proc-add! '("##inline-host-declaration" (1) #t 0 0 (#f) extended))
(define (univ-switch-testable? targ obj)
;;(pretty-print (list 'univ-switch-testable? 'targ obj))
#f);;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (univ-eq-testable? targ obj)
;;(pretty-print (list 'univ-eq-testable? 'targ obj))
#f);;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (univ-object-type targ obj)
;;(pretty-print (list 'univ-object-type 'targ obj))
'bignum);;;;;;;;;;;;;;;;;;;;;;;;;
;; ***** TARGET CODE EMITTERS
(define-macro (^ . forms)
(if (null? forms)
`'()
`(list ,@forms)))
(define-macro (^var-declaration name #!optional (expr #f))
`(univ-emit-var-declaration ctx ,name ,expr))
(define-macro (^expr-statement expr)
`(univ-emit-expr-statement ctx ,expr))
(define-macro (^if test true #!optional (false #f))
`(univ-emit-if ctx ,test ,true ,false))
(define-macro (^if-expr expr1 expr2 expr3)
`(univ-emit-if-expr ctx ,expr1 ,expr2 ,expr3))
(define-macro (^while test body)
`(univ-emit-while ctx ,test ,body))
(define-macro (^eq? expr1 expr2)
`(univ-emit-eq? ctx ,expr1 ,expr2))
(define-macro (^+ expr1 #!optional (expr2 #f))
`(univ-emit-+ ctx ,expr1 ,expr2))
(define-macro (^- expr1 #!optional (expr2 #f))
`(univ-emit-- ctx ,expr1 ,expr2))
(define-macro (^* expr1 expr2)
`(univ-emit-* ctx ,expr1 ,expr2))
(define-macro (^/ expr1 expr2)
`(univ-emit-/ ctx ,expr1 ,expr2))
(define-macro (^<< expr1 expr2)
`(univ-emit-<< ctx ,expr1 ,expr2))
(define-macro (^>> expr1 expr2)
`(univ-emit->> ctx ,expr1 ,expr2))
(define-macro (^>>> expr1 expr2)
`(univ-emit->>> ctx ,expr1 ,expr2))
(define-macro (^bitnot expr)
`(univ-emit-bitnot ctx ,expr))
(define-macro (^bitand expr1 expr2)
`(univ-emit-bitand ctx ,expr1 ,expr2))
(define-macro (^bitior expr1 expr2)
`(univ-emit-bitior ctx ,expr1 ,expr2))
(define-macro (^bitxor expr1 expr2)
`(univ-emit-bitxor ctx ,expr1 ,expr2))
(define-macro (^= expr1 expr2)
`(univ-emit-= ctx ,expr1 ,expr2))
(define-macro (^!= expr1 expr2)
`(univ-emit-!= ctx ,expr1 ,expr2))
(define-macro (^< expr1 expr2)
`(univ-emit-< ctx ,expr1 ,expr2))
(define-macro (^<= expr1 expr2)
`(univ-emit-<= ctx ,expr1 ,expr2))
(define-macro (^> expr1 expr2)
`(univ-emit-> ctx ,expr1 ,expr2))
(define-macro (^>= expr1 expr2)
`(univ-emit->= ctx ,expr1 ,expr2))
(define-macro (^not expr)
`(univ-emit-not ctx ,expr))
(define-macro (^&& expr1 expr2)
`(univ-emit-&& ctx ,expr1 ,expr2))
(define-macro (^and expr1 expr2)
`(univ-emit-and ctx ,expr1 ,expr2))
(define-macro (^or expr1 expr2)
`(univ-emit-or ctx ,expr1 ,expr2))
(define-macro (^concat expr1 expr2)
`(univ-emit-concat ctx ,expr1 ,expr2))
(define-macro (^tostr expr)
`(univ-emit-tostr ctx ,expr))
(define-macro (^parens expr)
`(univ-emit-parens ctx ,expr))
(define-macro (^parens-php expr)
`(univ-emit-parens-php ctx ,expr))
(define-macro (^local-var name)
`(univ-emit-local-var ctx ,name))
(define-macro (^global-var name)
`(univ-emit-global-var ctx ,name))
(define-macro (^gvar name)
`(univ-emit-gvar ctx ,name))
(define-macro (^global-function name)
`(univ-emit-global-function ctx ,name))
(define-macro (^prefix name)
`(univ-emit-prefix ctx ,name))
(define-macro (^prefix-class name)
`(univ-emit-prefix-class ctx ,name))
(define-macro (^assign-expr loc expr)
`(univ-emit-assign-expr ctx ,loc ,expr))
(define-macro (^assign loc expr)
`(univ-emit-assign ctx ,loc ,expr))
(define-macro (^inc-by loc expr #!optional (embed #f))
`(univ-emit-inc-by ctx ,loc ,expr ,embed))
(define-macro (^alias expr)
`(univ-emit-alias ctx ,expr))
(define-macro (^unalias expr)
`(univ-emit-unalias ctx ,expr))
(define-macro (^array-length expr)
`(univ-emit-array-length ctx ,expr))
(define-macro (^array-shrink! expr1 expr2)
`(univ-emit-array-shrink! ctx ,expr1 ,expr2))
(define-macro (^copy-array-to-extensible-array expr len)
`(univ-emit-copy-array-to-extensible-array ctx ,expr ,len))
(define-macro (^extensible-array-to-array! var len)
`(univ-emit-extensible-array-to-array! ctx ,var ,len))
(define-macro (^subarray expr1 expr2 expr3)
`(univ-emit-subarray ctx ,expr1 ,expr2 ,expr3))
(define-macro (^array-index expr1 expr2)
`(univ-emit-array-index ctx ,expr1 ,expr2))
(define-macro (^prop-index expr1 expr2 #!optional (expr3 #f))
`(univ-emit-prop-index ctx ,expr1 ,expr2 ,expr3))
(define-macro (^prop-index-exists? expr1 expr2)
`(univ-emit-prop-index-exists? ctx ,expr1 ,expr2))
(define-macro (^get obj name)
`(univ-emit-get ctx ,obj ,name))
(define-macro (^set obj name val)
`(univ-emit-set ctx ,obj ,name ,val))
(define-macro (^obj obj)
`(univ-emit-obj ctx ,obj))
(define-macro (^array-literal elems)
`(univ-emit-array-literal ctx ,elems))
(define-macro (^extensible-array-literal elems)
`(univ-emit-extensible-array-literal ctx ,elems))
(define-macro (^empty-dict)
`(univ-emit-empty-dict ctx))
(define-macro (^call-prim expr . params)
`(univ-emit-call-prim ctx ,expr ,@params))
(define-macro (^call expr . params)
`(univ-emit-call ctx ,expr ,@params))
(define-macro (^apply expr params)
`(univ-emit-apply ctx ,expr ,params))
(define-macro (^this)
`(univ-emit-this ctx))
(define-macro (^this-member name)
`(univ-emit-this-member ctx ,name))
(define-macro (^new class . params)
`(univ-emit-new ctx ,class ,@params))
(define-macro (^typeof type expr)
`(univ-emit-typeof ctx ,type ,expr))
(define-macro (^instanceof class expr)
`(univ-emit-instanceof ctx ,class ,expr))
(define-macro (^getopnd opnd)
`(univ-emit-getopnd ctx ,opnd))
(define-macro (^setloc loc val)
`(univ-emit-setloc ctx ,loc ,val))
(define-macro (^procedure-declaration global? root-name params header attribs body)
`(univ-emit-procedure-declaration
ctx
,global?
,root-name
,params
,header
,attribs
(lambda (ctx) ,body)))
(define-macro (^prim-function-declaration root-name params header attribs body)
`(^function-declaration
#t
,root-name
,params
,header
,attribs
,body
#t))
(define-macro (^function-declaration global? root-name params header attribs body #!optional (prim? #f))
`(univ-emit-function-declaration
ctx
,global?
,root-name
,params
,header
,attribs
(lambda (ctx) ,body)
,prim?))
(define-macro (^class-declaration root-name extends fields methods #!optional (constructor #f))
`(univ-emit-class-declaration
ctx
,root-name
,extends
,fields
,methods
,constructor))
(define-macro (^tos)
`(univ-emit-tos ctx))
(define-macro (^pop receiver)
`(univ-emit-pop ctx ,receiver))
(define-macro (^push val)
`(univ-emit-push ctx ,val))
(define-macro (^getnargs)
`(univ-emit-getnargs ctx))
(define-macro (^setnargs nb-args)
`(univ-emit-setnargs ctx ,nb-args))
(define-macro (^getreg num)
`(univ-emit-getreg ctx ,num))
(define-macro (^setreg num val)
`(univ-emit-setreg ctx ,num ,val))
(define-macro (^getstk offset)
`(univ-emit-getstk ctx ,offset))
(define-macro (^setstk offset val)
`(univ-emit-setstk ctx ,offset ,val))
(define-macro (^getclo closure index)
`(univ-emit-getclo ctx ,closure ,index))
(define-macro (^setclo closure index val)
`(univ-emit-setclo ctx ,closure ,index ,val))
(define-macro (^getprm name)
`(univ-emit-getprm ctx ,name))
(define-macro (^setprm name val)
`(univ-emit-setprm ctx ,name ,val))
(define-macro (^getglo name)
`(univ-emit-getglo ctx ,name))
(define-macro (^setglo name val)
`(univ-emit-setglo ctx ,name ,val))
(define-macro (^glo-var-ref sym)
`(univ-emit-glo-var-ref ctx ,sym))
(define-macro (^glo-var-primitive-ref sym)
`(univ-emit-glo-var-primitive-ref ctx ,sym))
(define-macro (^glo-var-set! sym val)
`(univ-emit-glo-var-set! ctx ,sym ,val))
(define-macro (^glo-var-primitive-set! sym val)
`(univ-emit-glo-var-primitive-set! ctx ,sym ,val))
(define-macro (^return-poll expr poll? call?)
`(univ-emit-return-poll ctx ,expr ,poll? ,call?))
(define-macro (^return-call-prim expr . params)
`(univ-emit-return-call-prim ctx ,expr ,@params))
(define-macro (^return-call expr)
`(univ-emit-return-call ctx ,expr))
(define-macro (^return expr)
`(univ-emit-return ctx ,expr))
(define-macro (^null)
`(univ-emit-null ctx))
(define-macro (^void)
`(univ-emit-void ctx))
(define-macro (^eof)
`(univ-emit-eof ctx))
(define-macro (^absent)
`(univ-emit-absent ctx))
(define-macro (^unbound1)
`(univ-emit-unbound1 ctx))
(define-macro (^unbound2)
`(univ-emit-unbound2 ctx))
(define-macro (^unbound? val)
`(univ-emit-unbound? ctx ,val))
(define-macro (^optional)
`(univ-emit-optional ctx))
(define-macro (^key)
`(univ-emit-key ctx))
(define-macro (^rest)
`(univ-emit-rest ctx))
(define-macro (^bool val)
`(univ-emit-bool ctx ,val))
(define-macro (^boolean-obj obj)
`(univ-emit-boolean-obj ctx ,obj))
(define-macro (^boolean-box val)
`(univ-emit-boolean-box ctx ,val))
(define-macro (^boolean-unbox boolean)
`(univ-emit-boolean-unbox ctx ,boolean))
(define-macro (^boolean? val)
`(univ-emit-boolean? ctx ,val))
(define-macro (^chr val)
`(univ-emit-chr ctx ,val))
(define-macro (^char-obj obj force-var?)
`(univ-emit-char-obj ctx ,obj ,force-var?))
(define-macro (^char-box val)
`(univ-emit-char-box ctx ,val))
(define-macro (^char-box-uninterned val)
`(univ-emit-char-box-uninterned ctx ,val))
(define-macro (^char-unbox char)
`(univ-emit-char-unbox ctx ,char))
(define-macro (^chr-fromint val)
`(univ-emit-chr-fromint ctx ,val))
(define-macro (^chr-toint val)
`(univ-emit-chr-toint ctx ,val))
(define-macro (^chr-tostr val)
`(univ-emit-chr-tostr ctx ,val))
(define-macro (^char? val)
`(univ-emit-char? ctx ,val))
(define-macro (^int val)
`(univ-emit-int ctx ,val))
(define-macro (^fixnum-box val)
`(univ-emit-fixnum-box ctx ,val))
(define-macro (^fixnum-unbox fixnum)
`(univ-emit-fixnum-unbox ctx ,fixnum))
(define-macro (^fixnum? val)
`(univ-emit-fixnum? ctx ,val))
(define-macro (^dict alist)
`(univ-emit-dict ctx ,alist))
(define-macro (^member expr name)
`(univ-emit-member ctx ,expr ,name))
(define-macro (^pair? expr)
`(univ-emit-pair? ctx ,expr))
(define-macro (^cons expr1 expr2)
`(univ-emit-cons ctx ,expr1 ,expr2))
(define-macro (^getcar expr)
`(univ-emit-getcar ctx ,expr))
(define-macro (^getcdr expr)
`(univ-emit-getcdr ctx ,expr))
(define-macro (^setcar expr1 expr2)
`(univ-emit-setcar ctx ,expr1 ,expr2))
(define-macro (^setcdr expr1 expr2)
`(univ-emit-setcdr ctx ,expr1 ,expr2))
(define-macro (^float val)
`(univ-emit-float ctx ,val))
(define-macro (^float-fromint val)
`(univ-emit-float-fromint ctx ,val))
(define-macro (^float-toint val)
`(univ-emit-float-toint ctx ,val))
(define-macro (^float-abs val)
`(univ-emit-float-abs ctx ,val))
(define-macro (^float-floor val)
`(univ-emit-float-floor ctx ,val))
(define-macro (^float-ceiling val)
`(univ-emit-float-ceiling ctx ,val))
(define-macro (^float-truncate val)
`(univ-emit-float-truncate ctx ,val))
(define-macro (^float-round-half-up val)
`(univ-emit-float-round-half-up ctx ,val))
(define-macro (^float-round-half-towards-0 val)
`(univ-emit-float-round-half-towards-0 ctx ,val))
(define-macro (^float-round-half-to-even val)
`(univ-emit-float-round-half-to-even ctx ,val))
(define-macro (^float-mod val1 val2)
`(univ-emit-float-mod ctx ,val1 ,val2))
(define-macro (^float-exp val)
`(univ-emit-float-exp ctx ,val))
(define-macro (^float-log val)
`(univ-emit-float-log ctx ,val))
(define-macro (^float-sin val)
`(univ-emit-float-sin ctx ,val))
(define-macro (^float-cos val)
`(univ-emit-float-cos ctx ,val))
(define-macro (^float-tan val)
`(univ-emit-float-tan ctx ,val))
(define-macro (^float-asin val)
`(univ-emit-float-asin ctx ,val))
(define-macro (^float-acos val)
`(univ-emit-float-acos ctx ,val))
(define-macro (^float-atan val)
`(univ-emit-float-atan ctx ,val))
(define-macro (^float-atan2 val1 val2)
`(univ-emit-float-atan2 ctx ,val1 ,val2))
(define-macro (^float-expt val1 val2)
`(univ-emit-float-expt ctx ,val1 ,val2))
(define-macro (^float-sqrt val)
`(univ-emit-float-sqrt ctx ,val))
(define-macro (^float-integer? val)
`(univ-emit-float-integer? ctx ,val))
(define-macro (^float-finite? val)
`(univ-emit-float-finite? ctx ,val))
(define-macro (^float-infinite? val)
`(univ-emit-float-infinite? ctx ,val))
(define-macro (^float-nan? val)
`(univ-emit-float-nan? ctx ,val))
(define-macro (^flonum-box val)
`(univ-emit-flonum-box ctx ,val))
(define-macro (^flonum-unbox flonum)
`(univ-emit-flonum-unbox ctx ,flonum))
(define-macro (^flonum? val)
`(univ-emit-flonum? ctx ,val))
(define-macro (^cpxnum-make expr1 expr2)
`(univ-emit-cpxnum-make ctx ,expr1 ,expr2))
(define-macro (^cpxnum? val)
`(univ-emit-cpxnum? ctx ,val))
(define-macro (^ratnum-make expr1 expr2)
`(univ-emit-ratnum-make ctx ,expr1 ,expr2))
(define-macro (^ratnum? val)
`(univ-emit-ratnum? ctx ,val))
(define-macro (^bignum expr1 expr2)
`(univ-emit-bignum ctx ,expr1 ,expr2))
(define-macro (^bignum? val)
`(univ-emit-bignum? ctx ,val))
(define-macro (^vector-box val)
`(univ-emit-vector-box ctx ,val))
(define-macro (^vector-unbox vector)
`(univ-emit-vector-unbox ctx ,vector))
(define-macro (^vector? val)
`(univ-emit-vector? ctx ,val))
(define-macro (^vector-length val)
`(univ-emit-vector-length ctx ,val))
(define-macro (^vector-shrink! val1 val2)
`(univ-emit-vector-shrink! ctx ,val1 ,val2))
(define-macro (^vector-ref val1 val2)
`(univ-emit-vector-ref ctx ,val1 ,val2))
(define-macro (^vector-set! val1 val2 val3)
`(univ-emit-vector-set! ctx ,val1 ,val2 ,val3))
(define-macro (^u8vector-box val)
`(univ-emit-u8vector-box ctx ,val))
(define-macro (^u8vector-unbox u8vector)
`(univ-emit-u8vector-unbox ctx ,u8vector))
(define-macro (^u8vector? val)
`(univ-emit-u8vector? ctx ,val))
(define-macro (^u8vector-length val)
`(univ-emit-u8vector-length ctx ,val))
(define-macro (^u8vector-shrink! val1 val2)
`(univ-emit-u8vector-shrink! ctx ,val1 ,val2))
(define-macro (^u8vector-ref val1 val2)
`(univ-emit-u8vector-ref ctx ,val1 ,val2))
(define-macro (^u8vector-set! val1 val2 val3)
`(univ-emit-u8vector-set! ctx ,val1 ,val2 ,val3))
(define-macro (^u16vector-box val)
`(univ-emit-u16vector-box ctx ,val))
(define-macro (^u16vector-unbox u16vector)
`(univ-emit-u16vector-unbox ctx ,u16vector))
(define-macro (^u16vector? val)
`(univ-emit-u16vector? ctx ,val))
(define-macro (^u16vector-length val)
`(univ-emit-u16vector-length ctx ,val))
(define-macro (^u16vector-shrink! val1 val2)
`(univ-emit-u16vector-shrink! ctx ,val1 ,val2))
(define-macro (^u16vector-ref val1 val2)
`(univ-emit-u16vector-ref ctx ,val1 ,val2))
(define-macro (^u16vector-set! val1 val2 val3)
`(univ-emit-u16vector-set! ctx ,val1 ,val2 ,val3))
(define-macro (^f64vector-box val)
`(univ-emit-f64vector-box ctx ,val))
(define-macro (^f64vector-unbox f64vector)
`(univ-emit-f64vector-unbox ctx ,f64vector))
(define-macro (^f64vector? val)
`(univ-emit-f64vector? ctx ,val))
(define-macro (^f64vector-length val)
`(univ-emit-f64vector-length ctx ,val))
(define-macro (^f64vector-shrink! val1 val2)
`(univ-emit-f64vector-shrink! ctx ,val1 ,val2))
(define-macro (^f64vector-ref val1 val2)
`(univ-emit-f64vector-ref ctx ,val1 ,val2))
(define-macro (^f64vector-set! val1 val2 val3)
`(univ-emit-f64vector-set! ctx ,val1 ,val2 ,val3))
(define-macro (^structure-box val)
`(univ-emit-structure-box ctx ,val))
(define-macro (^structure-unbox structure)
`(univ-emit-structure-unbox ctx ,structure))
(define-macro (^structure? val)
`(univ-emit-structure? ctx ,val))
(define-macro (^structure-ref val1 val2)
`(univ-emit-structure-ref ctx ,val1 ,val2))
(define-macro (^structure-set! val1 val2 val3)
`(univ-emit-structure-set! ctx ,val1 ,val2 ,val3))
(define-macro (^str val)
`(univ-emit-str ctx ,val))
(define-macro (^strtocodes val)
`(univ-emit-strtocodes ctx ,val))
(define-macro (^string-obj obj force-var?)
`(univ-emit-string-obj ctx ,obj ,force-var?))
(define-macro (^string-box val)
`(univ-emit-string-box ctx ,val))
(define-macro (^string-unbox string)
`(univ-emit-string-unbox ctx ,string))
(define-macro (^string? val)
`(univ-emit-string? ctx ,val))
(define-macro (^string-length val)
`(univ-emit-string-length ctx ,val))
(define-macro (^string-shrink! val1 val2)
`(univ-emit-string-shrink! ctx ,val1 ,val2))
(define-macro (^string-ref val1 val2)
`(univ-emit-string-ref ctx ,val1 ,val2))
(define-macro (^string-set! val1 val2 val3)
`(univ-emit-string-set! ctx ,val1 ,val2 ,val3))
(define-macro (^symbol-obj obj force-var?)
`(univ-emit-symbol-obj ctx ,obj ,force-var?))
(define-macro (^symbol-box val)
`(univ-emit-symbol-box ctx ,val))
(define-macro (^symbol-box-uninterned val)
`(univ-emit-symbol-box-uninterned ctx ,val))
(define-macro (^symbol-unbox symbol)
`(univ-emit-symbol-unbox ctx ,symbol))
(define-macro (^symbol? val)
`(univ-emit-symbol? ctx ,val))
(define-macro (^keyword-obj obj force-var?)
`(univ-emit-keyword-obj ctx ,obj ,force-var?))
(define-macro (^keyword-box val)
`(univ-emit-keyword-box ctx ,val))
(define-macro (^keyword-box-uninterned val)
`(univ-emit-keyword-box-uninterned ctx ,val))
(define-macro (^keyword-unbox keyword)
`(univ-emit-keyword-unbox ctx ,keyword))
(define-macro (^keyword? val)
`(univ-emit-keyword? ctx ,val))
(define-macro (^box? val)
`(univ-emit-box? ctx ,val))
(define-macro (^box val)
`(univ-emit-box ctx ,val))
(define-macro (^unbox val)
`(univ-emit-unbox ctx ,val))
(define-macro (^setbox val1 val2)
`(univ-emit-setbox ctx ,val1 ,val2))
(define-macro (^frame? val)
`(univ-emit-frame? ctx ,val))
(define-macro (^continuation? val)
`(univ-emit-continuation? ctx ,val))
(define-macro (^procedure? val)
`(univ-emit-procedure? ctx ,val))
(define-macro (^closure? val)
`(univ-emit-closure? ctx ,val))
(define-macro (^closure-length val)
`(univ-emit-closure-length ctx ,val))
(define-macro (^closure-code val)
`(univ-emit-closure-code ctx ,val))
(define-macro (^closure-ref val1 val2)
`(univ-emit-closure-ref ctx ,val1 ,val2))
(define-macro (^closure-set! val1 val2 val3)
`(univ-emit-closure-set! ctx ,val1 ,val2 ,val3))
(define-macro (^popcount! arg)
`(univ-emit-popcount! ctx ,arg))
(define (univ-emit-popcount! ctx arg)
(define (popcount arg acc len)
(if (>= len univ-word-bits)
(^ acc
(^assign arg (^bitand arg (^int #x0000003F))))
(popcount
arg
(^ acc
(case len
((1)
(^assign arg (^- arg
(^parens (^bitand (^parens (^>> arg (^int 1)))
(^int #x55555555))))))
((2)
(^assign arg (^+ (^parens (^bitand arg (^int #x33333333)))
(^parens (^bitand (^parens (^>> arg (^int 2)))
(^int #x33333333))))))
((4)
(^assign arg (^bitand (^parens (^+ arg (^parens (^>> arg (^int 4)))))
(^int #x0F0F0F0F))))
(else
(^assign arg (^+ arg (^parens (^>> arg len)))))))
(* len 2))))
(popcount arg
(^assign arg (^bitand arg (^int univ-fixnum-max*2+1)))
1))
(define (univ-emit-var-declaration ctx name #!optional (expr #f))
(case (target-name (ctx-target ctx))
((js)
(^ "var " name (if expr (^ " = " expr) (^)) ";\n"))
((python ruby)
(^ name " = " (or expr (^obj #f)) "\n"))
((php)
(^ name " = " (or expr (^obj #f)) ";\n"))
(else
(compiler-internal-error
"univ-emit-var-declaration, unknown target"))))
(define (univ-emit-expr-statement ctx expr)
(case (target-name (ctx-target ctx))
((js php)
(^ expr ";\n"))
((python ruby)
(^ expr "\n"))
(else
(compiler-internal-error
"univ-emit-expr-statement, unknown target"))))
(define (univ-emit-if ctx test true #!optional (false #f))
(case (target-name (ctx-target ctx))
((js php)
(^ "if (" test ") {\n"
(univ-indent true)
(if false
(^ "} else {\n"
(univ-indent false))
(^))
"}\n"))
((python)
(^ "if " test ":\n"
(univ-indent true)
(if false
(^ "else:\n"
(univ-indent false))
(^))))
((ruby)
(^ "if " test "\n"
(univ-indent true)
(if false
(^ "else\n"
(univ-indent false))
(^))
"end\n"))
(else
(compiler-internal-error
"univ-emit-if, unknown target"))))
(define (univ-emit-if-expr ctx expr1 expr2 expr3)
(case (target-name (ctx-target ctx))
((js ruby)
(^ expr1 " ? " expr2 " : " expr3))
((php)
(^parens (^ expr1 " ? " expr2 " : " expr3)))
((python)
(^ expr2 " if " expr1 " else " expr3))
(else
(compiler-internal-error
"univ-emit-if-expr, unknown target"))))
(define (univ-emit-while ctx test body)
(case (target-name (ctx-target ctx))
((js php)
(^ "while (" test ") {\n"
(univ-indent body)
"}\n"))
((python)
(^ "while " test ":\n"
(univ-indent body)))
((ruby)
(^ "while " test "\n"
(univ-indent body)
"end\n"))
(else
(compiler-internal-error
"univ-emit-while, unknown target"))))
(define (univ-emit-eq? ctx expr1 expr2)
(case (target-name (ctx-target ctx))
((js php)
(^ expr1 " === " expr2))
((python)
(^ expr1 " is " expr2))
((ruby)
(^ expr1 ".equal?(" expr2 ")"))
(else
(compiler-internal-error
"univ-emit-eq?, unknown target"))))
(define (univ-emit-+ ctx expr1 #!optional (expr2 #f))
(case (target-name (ctx-target ctx))
((js php python ruby)
(if expr2
(^ expr1 " + " expr2)
(^ "+ " expr1)))
(else
(compiler-internal-error
"univ-emit-+, unknown target"))))
(define (univ-emit-- ctx expr1 #!optional (expr2 #f))
(case (target-name (ctx-target ctx))
((js php python ruby)
(if expr2
(^ expr1 " - " expr2)
(^ "- " expr1)))
(else
(compiler-internal-error
"univ-emit--, unknown target"))))
(define (univ-emit-* ctx expr1 expr2)
(case (target-name (ctx-target ctx))
((js php python ruby)
(^ expr1 " * " expr2))
(else
(compiler-internal-error
"univ-emit-*, unknown target"))))
(define (univ-emit-/ ctx expr1 expr2)
(case (target-name (ctx-target ctx))
((js php python ruby)
(^ expr1 " / " expr2))
(else
(compiler-internal-error
"univ-emit-/, unknown target"))))
(define (univ-wrap+ ctx expr1 expr2)
(case (target-name (ctx-target ctx))
((js)
(^>> (^<< (^parens (^+ expr1 expr2))
univ-tag-bits)
univ-tag-bits))
((python)
(^>> (^member (^call-prim
"ctypes.c_int32"
(^<< (^parens (^+ expr1 expr2))
univ-tag-bits))
'value)
univ-tag-bits))
((ruby php)
(^- (^parens (^bitand (^parens (^+ (^+ expr1 expr2)
univ-fixnum-max+1))
univ-fixnum-max*2+1))
univ-fixnum-max+1))
(else
(compiler-internal-error
"univ-wrap+, unknown target"))))
(define (univ-wrap- ctx expr1 #!optional (expr2 #f))
(case (target-name (ctx-target ctx))
((js)
(^>> (^<< (^parens (if expr2
(^- expr1 expr2)
(^- expr1)))
univ-tag-bits)
univ-tag-bits))
((python)
(^>> (^member (^call-prim
"ctypes.c_int32"
(^<< (^parens (if expr2
(^- expr1 expr2)
(^- expr1)))
univ-tag-bits))
'value)
univ-tag-bits))
((ruby php)
(^- (^parens (^bitand (^parens (^+ (if expr2
(^- expr1 expr2)
(^- expr1))
univ-fixnum-max+1))
univ-fixnum-max*2+1))
univ-fixnum-max+1))
(else
(compiler-internal-error
"univ-wrap-, unknown target"))))
(define (univ-wrap* ctx expr1 expr2)
(case (target-name (ctx-target ctx))
((js)
(^>> (^parens
(^<< (^parens
(^+ (^* (^parens (^bitand expr1 #xffff))
expr2)
(^* (^parens (^bitand expr1 #xffff0000))
(^parens (^bitand expr2 #xffff)))))
univ-tag-bits))
univ-tag-bits))
((python)
(^>> (^member (^call-prim
"ctypes.c_int32"
(^<< (^parens (^* expr1 expr2))
univ-tag-bits))
'value)
univ-tag-bits))
((ruby php)
(^- (^parens (^bitand (^parens (^+ (^* expr1 expr2)
univ-fixnum-max+1))
univ-fixnum-max*2+1))
univ-fixnum-max+1))
(else
(compiler-internal-error
"univ-wrap*, unknown target"))))
(define (univ-emit-<< ctx expr1 expr2)
(case (target-name (ctx-target ctx))
((js php python ruby)
(^ expr1 " << " expr2))
(else
(compiler-internal-error
"univ-emit-<<, unknown target"))))
(define (univ-emit->> ctx expr1 expr2)
(case (target-name (ctx-target ctx))
((js php python ruby)
(^ expr1 " >> " expr2))
(else
(compiler-internal-error
"univ-emit->>, unknown target"))))
(define (univ-emit->>> ctx expr1 expr2)
(case (target-name (ctx-target ctx))
((js)
(^ expr1 " >>> " expr2))
(else
(compiler-internal-error
"univ-emit->>>, unknown target"))))
(define (univ-emit-bitnot ctx expr)
(case (target-name (ctx-target ctx))
((js php python ruby)
(^ "~ " expr))
(else
(compiler-internal-error
"univ-emit-bitnot, unknown target"))))
(define (univ-emit-bitand ctx expr1 expr2)
(case (target-name (ctx-target ctx))
((js php python ruby)
(^ expr1 " & " expr2))
(else
(compiler-internal-error
"univ-emit-bitand, unknown target"))))
(define (univ-emit-bitior ctx expr1 expr2)
(case (target-name (ctx-target ctx))
((js php python ruby)
(^ expr1 " | " expr2))
(else
(compiler-internal-error
"univ-emit-bitior, unknown target"))))
(define (univ-emit-bitxor ctx expr1 expr2)
(case (target-name (ctx-target ctx))
((js php python ruby)
(^ expr1 " ^ " expr2))
(else
(compiler-internal-error
"univ-emit-bitxor, unknown target"))))
(define (univ-emit-= ctx expr1 expr2)
(case (target-name (ctx-target ctx))
((js)
(^ expr1 " === " expr2))
((python ruby php)
(^ expr1 " == " expr2))
(else
(compiler-internal-error
"univ-emit-=, unknown target"))))
(define (univ-emit-!= ctx expr1 expr2)
(case (target-name (ctx-target ctx))
((js)
(^ expr1 " !== " expr2))
((python ruby php)
(^ expr1 " != " expr2))
(else
(compiler-internal-error
"univ-emit-!=, unknown target"))))
(define (univ-emit-< ctx expr1 expr2)
(univ-emit-comparison ctx " < " expr1 expr2))
(define (univ-emit-<= ctx expr1 expr2)
(univ-emit-comparison ctx " <= " expr1 expr2))
(define (univ-emit-> ctx expr1 expr2)
(univ-emit-comparison ctx " > " expr1 expr2))
(define (univ-emit->= ctx expr1 expr2)
(univ-emit-comparison ctx " >= " expr1 expr2))
(define (univ-emit-comparison ctx comp expr1 expr2)
(case (target-name (ctx-target ctx))
((js python ruby php)
(^ expr1 comp expr2))
(else
(compiler-internal-error
"univ-emit-comparison, unknown target"))))
(define (univ-emit-not ctx expr)
(case (target-name (ctx-target ctx))
((js php ruby)
(^ "!" expr))
((python)
(^ "not " expr))
(else
(compiler-internal-error
"univ-emit-not, unknown target"))))
(define (univ-emit-&& ctx expr1 expr2)
(case (target-name (ctx-target ctx))
((js ruby php)
(^ expr1 " && " expr2))
((python)
(^ expr1 " and " expr2))
(else
(compiler-internal-error
"univ-emit-&&, unknown target"))))
(define (univ-emit-and ctx expr1 expr2)
(case (target-name (ctx-target ctx))
((js ruby)
(^ expr1 " && " expr2))
((python)
(^ expr1 " and " expr2))
((php)
(^ expr1 " ? " expr2 " : false"))
(else
(compiler-internal-error
"univ-emit-and, unknown target"))))
(define (univ-emit-or ctx expr1 expr2)
(case (target-name (ctx-target ctx))
((js ruby php)
(^ expr1 " || " expr2)) ;; TODO: PHP || operator always yields a boolean
((python)
(^ expr1 " or " expr2))
(else
(compiler-internal-error
"univ-emit-or, unknown target"))))
(define (univ-emit-concat ctx expr1 expr2)
(case (target-name (ctx-target ctx))
((js python ruby)
(^ expr1 " + " expr2))
((php)
(^ expr1 " . " expr2))
(else
(compiler-internal-error
"univ-emit-concat, unknown target"))))
(define (univ-emit-tostr ctx expr)
(case (target-name (ctx-target ctx))
((js)
(^ expr ".toString()"))
((python)
(^ "str(" expr ")"))
((php)
(^ "(string)" expr))
((ruby)
(^ expr ".to_s"))
(else
(compiler-internal-error
"univ-emit-tostr, unknown target"))))
(define (univ-emit-parens ctx expr)
(case (target-name (ctx-target ctx))
((js ruby php python)
(^ "(" expr ")"))
(else
(compiler-internal-error
"univ-emit-parens, unknown target"))))
(define (univ-emit-parens-php ctx expr)
(if (eq? (target-name (ctx-target ctx)) 'php)
(^parens expr)
expr))
(define (univ-emit-local-var ctx name)
(case (target-name (ctx-target ctx))
((js python ruby)
name)
((php)
(^ "$" name))
(else
(compiler-internal-error
"univ-emit-local-var, unknown target"))))
(define (univ-emit-global-var ctx name)
(case (target-name (ctx-target ctx))
((js python)
name)
((php ruby)
(^ "$" name))
(else
(compiler-internal-error
"univ-emit-global-var, unknown target"))))
(define (univ-emit-gvar ctx name)
(let ((var (^global-var (^prefix name))))
(use-global ctx var)
var))
(define (univ-emit-global-function ctx name)
(case (target-name (ctx-target ctx))
((js python)
name)
((php ruby)
(^ "$" name))
(else
(compiler-internal-error
"univ-emit-global-function, unknown target"))))
(define (univ-emit-prefix ctx name)
(^ "gambit_" name))
(define (univ-emit-prefix-class ctx name)
(^ "Gambit_" name))
(define (univ-emit-assign-expr ctx loc expr)
(^ loc " = " expr))
(define (univ-emit-assign ctx loc expr)
(^expr-statement
(^assign-expr loc expr)))
(define (univ-emit-inc-by ctx loc expr #!optional (embed #f))
(define (embed-read x)
(if embed
(embed x)
(^)))
(define (embed-expr x)
(if embed
(embed x)
(^expr-statement x)))
(define (inc-general loc expr)
(if (and (number? expr) (< expr 0))
(^ loc " -= " (- expr))
(^ loc " += " expr)))
(if (equal? expr 0)
(embed-read loc)
(case (target-name (ctx-target ctx))
((js php)
(cond ((equal? expr 1)
(embed-expr (^ "++" loc)))
((equal? expr -1)
(embed-expr (^ "--" loc)))
(else
(embed-expr (^parens (inc-general loc expr))))))
((python)
(^ (^expr-statement (inc-general loc expr))
(embed-read loc)))
((ruby)
(embed-expr (^parens (inc-general loc expr))))
(else
(compiler-internal-error
"univ-emit-inc-by, unknown target")))))
(define (univ-emit-alias ctx expr)
(case (target-name (ctx-target ctx))
((js python ruby)
expr)
((php)
(^ "&" expr))
(else
(compiler-internal-error
"univ-emit-alias, unknown target"))))
(define (univ-emit-unalias ctx expr)
(case (target-name (ctx-target ctx))
((js python ruby)
(^))
((php)
(^expr-statement
(^ "unset(" expr ")")))
(else
(compiler-internal-error
"univ-emit-unalias, unknown target"))))
(define (univ-emit-array-length ctx expr)
(case (target-name (ctx-target ctx))
((js ruby)
(^ expr ".length"))
((php)
(^ "count(" expr ")"))
((python)
(^ "len(" expr ")"))
(else
(compiler-internal-error
"univ-emit-array-length, unknown target"))))
(define (univ-emit-array-shrink! ctx expr1 expr2)
(case (target-name (ctx-target ctx))
((js)
(^assign (^ expr1 ".length") expr2))
((php)
(^expr-statement
(^ "array_splice(" expr1 "," expr2 ")")))
((python)
(^expr-statement
(^ expr1 "[" expr2 ":] = []")))
((ruby)
(^expr-statement
(^ expr1 ".slice!(" expr2 "," expr1 ".length)")))
(else
(compiler-internal-error
"univ-emit-array-shrink!, unknown target"))))
(define (univ-emit-copy-array-to-extensible-array ctx expr len)
(case (target-name (ctx-target ctx))
((js php ruby)
(^subarray expr 0 len))
((python)
(^ "dict(zip(range(" len ")," expr "))"))
(else
(compiler-internal-error
"univ-emit-array-to-extensible-array, unknown target"))))
(define (univ-emit-extensible-array-to-array! ctx var len)
(case (target-name (ctx-target ctx))
((js php ruby)
(^))
((python)
(^assign var (^ "[" var "[i] for i in range(" len ")]")))
(else
(compiler-internal-error
"univ-emit-extensible-array-to-array!, unknown target"))))
(define (univ-emit-subarray ctx expr1 expr2 expr3)
(case (target-name (ctx-target ctx))
((js)
(^ expr1 ".slice(" expr2 "," (if (equal? expr2 0) expr3 (^+ expr2 expr3)) ")"))
((php)
(^ "array_slice(" expr1 "," expr2 "," expr3 ")"))
((python)
(^ expr1 "[" expr2 ":" (if (equal? expr2 0) expr3 (^+ expr2 expr3)) "]"))
((ruby)
(^ expr1 ".slice(" expr2 "," (if (equal? expr2 0) expr3 (^+ expr2 expr3)) ")"))
(else
(compiler-internal-error
"univ-emit-array-shrink!, unknown target"))))
(define (univ-emit-array-index ctx expr1 expr2)
(^ expr1 "[" expr2 "]"))
(define (univ-emit-prop-index ctx expr1 expr2 expr3)
(if expr3
(^if-expr (^prop-index-exists? expr1 expr2)
(^prop-index expr1 expr2)
expr3)
(^ expr1 "[" expr2 "]")))
(define (univ-emit-prop-index-exists? ctx expr1 expr2)
(case (target-name (ctx-target ctx))
((js)
(^ expr1 ".hasOwnProperty(" expr2 ")"))
((php)
(^ "array_key_exists(" expr2 "," expr1 ")"))
((python)
(^ expr2 " in " expr1))
((ruby)
(^ expr1 ".has_key?(" expr2 ")"))
(else
(compiler-internal-error
"univ-emit-prop-index-exists?, unknown target"))))
(define (univ-emit-get ctx obj name)
(case (target-name (ctx-target ctx))
((js python ruby)
(^prop-index obj (^str name)))
((php)
(^call-prim
(^prefix (univ-use-rtlib ctx 'get))
obj
(^str name)))
(else
(compiler-internal-error
"univ-emit-get, unknown target"))))
(define (univ-emit-set ctx obj name val)
(case (target-name (ctx-target ctx))
((js python ruby)
(^assign-expr (^prop-index obj (^str name)) val))
((php)
(^call-prim
(^prefix (univ-use-rtlib ctx 'set))
obj
(^str name)
val))
(else
(compiler-internal-error
"univ-emit-set, unknown target"))))
;; ***** DUMPING OF A COMPILATION MODULE
(define (univ-dump targ procs output c-intf module-descr unique-name options)
(call-with-output-file
output
(lambda (port)
(let* ((objs-used (make-objs-used))
(rtlib-features-used (make-resource-set))
(main-proc (list-ref procs 0))
(ctx (make-ctx targ
options
(proc-obj-name main-proc)
#f
objs-used
rtlib-features-used
(queue-empty)))
(code-procs (univ-dump-procs ctx procs))
(code-entry (univ-entry-point ctx main-proc))
(code-rtlib (if univ-dyn-load?
(^)
(univ-rtlib ctx)))
(code-header (univ-module-header ctx))
(code-objs (univ-dump-objs ctx))
(code-decls (queue->list (ctx-decls ctx))))
(univ-display (^ code-rtlib
code-header
code-decls
code-objs
code-procs
code-entry)
port))))
#f)
(define (univ-dump-objs ctx)
(let* ((objs-used (ctx-objs-used ctx))
(stack (reverse (objs-used-stack objs-used)))
(table (objs-used-table objs-used)))
(let loop ((count 0) (lst stack) (code (^)))
(if (pair? lst)
(loop (+ count 1)
(cdr lst)
(let ((obj (car lst)))
(if (proc-obj? obj)
code
(let ((state (table-ref table obj)))
(if (or (> (vector-ref state 0) 1) ;; use a variable?
(eq? (target-name (ctx-target ctx)) 'python)) ;; Python can't handle deep nestings
(let ((cst
(^array-index
(gvm-state-cst ctx)
count))
(val
(car (vector-ref state 1))))
(set-car! (vector-ref state 1) cst)
(^ code
(^assign cst val)))
code)))))
code))))
(define (univ-obj-use ctx obj force-var? gen-expr)
(if force-var?
(use-resource ctx 'rd 'cst))
(let* ((objs-used (ctx-objs-used ctx))
(table (objs-used-table objs-used))
(state (table-ref table obj #f)))
(if state ;; don't add to table if obj was added before
(begin
(vector-set! state 0 (+ (vector-ref state 0) 1)) ;; increment reference count
(vector-ref state 1))
(let* ((code (list #f))
(state (vector (if force-var? 2 1) code)))
(table-set! table obj state)
(set-car! code (gen-expr))
(let ((stack (objs-used-stack objs-used)))
(objs-used-stack-set! objs-used (cons obj stack)))
code))))
(define (make-objs-used)
(vector '()
(make-table test: eq?)))
(define (objs-used-stack ou) (vector-ref ou 0))
(define (objs-used-stack-set! ou x) (vector-set! ou 0 x))
(define (objs-used-table ou) (vector-ref ou 1))
(define (objs-used-table-set! ou x) (vector-set! ou 1 x))
(define (univ-dump-procs global-ctx procs)
(let ((proc-seen (queue-empty))
(proc-left (queue-empty)))
(define (scan-obj obj)
(if (and (proc-obj? obj)
(proc-obj-code obj)
(not (memq obj (queue->list proc-seen))))
(begin
(queue-put! proc-seen obj)
(queue-put! proc-left obj))))
(define (dump-proc p)
(define subprocs
(make-stretchable-vector #f))
(define subprocs-init
(list #f))
(define (scan-bbs ctx bbs)
(let* ((bb-done (make-stretchable-vector #f))
(bb-todo (queue-empty)))
(define (todo-lbl-num! n)
(queue-put! bb-todo (lbl-num->bb n bbs)))
(define (scan-bb ctx bb)
(if (stretchable-vector-ref bb-done (bb-lbl-num bb))
(^)
(begin
(stretchable-vector-set! bb-done (bb-lbl-num bb) #t)
(scan-bb-all ctx bb))))
(define (scan-bb-all ctx bb)
(scan-gvm-label
ctx
(bb-label-instr bb)
(lambda (ctx)
(scan-bb-all-except-label ctx bb))))
(define (scan-bb-all-except-label ctx bb)
(let loop ((lst (bb-non-branch-instrs bb))
(rev-res '()))
(if (pair? lst)
(loop (cdr lst)
(cons (scan-gvm-instr ctx (car lst))
rev-res))
(reverse
(cons (scan-gvm-instr ctx (bb-branch-instr bb))
rev-res)))))
(define (scan-gvm-label ctx gvm-instr proc)
(define (frame-info gvm-instr)
(let* ((frame
(gvm-instr-frame gvm-instr))
(fs
(frame-size frame))
(vars
(reverse (frame-slots frame)))
(link
(pos-in-list ret-var vars)))
(vector fs link)))
(with-stack-base-offset
ctx
(- (frame-size (gvm-instr-frame gvm-instr)))
(lambda (ctx)
(let* ((id
(gvm-bb-use ctx (label-lbl-num gvm-instr) (ctx-ns ctx)))
(header
(case (label-type gvm-instr)
((simple)
(^ "\n"))
((entry)
(if (label-entry-rest? gvm-instr)
(^ " "
(univ-comment
ctx
(if (label-entry-closed? gvm-instr)
"closure-entry-point (+rest)\n"
"entry-point (+rest)\n")))
(^ " "
(univ-comment
ctx
(if (label-entry-closed? gvm-instr)
"closure-entry-point\n"
"entry-point\n")))))
((return)
(^ " "
(univ-comment ctx "return-point\n")))
((task-entry)
(^ " "
(univ-comment ctx "task-entry-point\n")))
((task-return)
(^ " "
(univ-comment ctx "task-return-point\n")))
(else
(compiler-internal-error
"scan-gvm-label, unknown label type"))))
(gen-body
(lambda (ctx)
(^ (case (label-type gvm-instr)
((entry)
(univ-label-entry ctx
gvm-instr
(^global-function (^prefix id))))
(else
(^)))
(proc ctx)))))
(^ "\n"
(^procedure-declaration ;;TODO: method declaration
;; global?
#t
;; name
id
;; params
'()
;; header
header
;; attribs
(if (memq (label-type gvm-instr) '(entry return))
(let ((entry (bbs-entry-lbl-num bbs))
(lbl-num (label-lbl-num gvm-instr)))
(append
(let ((subproc-id
(stretchable-vector-length subprocs)))
(stretchable-vector-set!
subprocs
subproc-id
lbl-num)
(list (cons "id" (^int subproc-id))
(cons "parent"
(if (= lbl-num entry)
(^bool #f)
(lambda (ctx)
(univ-subproc-reference
ctx
entry))))))
(if (eq? (label-type gvm-instr) 'return)
(let ((info (frame-info gvm-instr)))
(list (cons "fs" (vector-ref info 0))
(cons "link" (+ (vector-ref info 1) 1))))
(append
(list (cons "nb_closed"
(if (label-entry-closed? gvm-instr)
(let* ((frame (gvm-instr-frame gvm-instr))
(nb-closed (length (frame-closed frame))))
(^int nb-closed))
(^int -1))))
(if (= lbl-num entry)
(list (cons "prm_name"
(lambda (ctx)
(univ-prm-name ctx (proc-obj-name p))))
(cons "subprocs"
subprocs-init)
(cons "info"
(^obj #f))) ;; TODO
'())))))
'())
;; body
(gen-body ctx)))))))
(define (scan-gvm-instr ctx gvm-instr)
;; TODO: combine with scan-gvm-opnd
(define (scan-opnd gvm-opnd)
(cond ((not gvm-opnd))
((lbl? gvm-opnd)
(todo-lbl-num! (lbl-num gvm-opnd)))
((obj? gvm-opnd)
(scan-obj (obj-val gvm-opnd)))
((clo? gvm-opnd)
(scan-opnd (clo-base gvm-opnd)))))
;;(write-gvm-instr gvm-instr ##stderr-port)(newline ##stderr-port);;;;;;;;;;;;;;;;;;
;; TODO: combine with scan-gvm-opnd
(case (gvm-instr-type gvm-instr)
((apply)
(for-each scan-opnd (apply-opnds gvm-instr))
(if (apply-loc gvm-instr)
(scan-opnd (apply-loc gvm-instr))))
((copy)
(scan-opnd (copy-opnd gvm-instr))
(scan-opnd (copy-loc gvm-instr)))
((close)
(for-each (lambda (parms)
(scan-opnd (closure-parms-loc parms))
(scan-opnd (make-lbl (closure-parms-lbl parms)))
(for-each scan-opnd (closure-parms-opnds parms)))
(close-parms gvm-instr)))
((ifjump)
(for-each scan-opnd (ifjump-opnds gvm-instr)))
((switch)
(scan-opnd (switch-opnd gvm-instr))
(for-each (lambda (c) (scan-obj (switch-case-obj c)))
(switch-cases gvm-instr)))
((jump)
(scan-opnd (jump-opnd gvm-instr))))
(case (gvm-instr-type gvm-instr)
((apply)
(let ((loc (apply-loc gvm-instr))
(prim (apply-prim gvm-instr))
(opnds (apply-opnds gvm-instr)))
(let ((proc (proc-obj-inline prim)))
(if (not proc)
(compiler-internal-error
"scan-gvm-instr, unknown 'prim'" prim)
(proc
ctx
(lambda (result)
(cond (loc ;; result is needed?
(^setloc loc (or result (^void))))
;; if result is not needed, don't generate expression
;;(result
;; (^expr-statement result))
(else
(^))))
opnds)))))
((copy)
(let ((loc (copy-loc gvm-instr))
(opnd (copy-opnd gvm-instr)))
(if opnd
(begin
(scan-gvm-opnd ctx loc);;;;;;;;;;;;;;;; needed?
(scan-gvm-opnd ctx opnd)
(^setloc loc (^getopnd opnd)))
(^))))
((close)
(let ()
(define (alloc lst rev-loc-names)
(if (pair? lst)
(let* ((parms (car lst))
(lbl (closure-parms-lbl parms))
(loc (closure-parms-loc parms))
(opnds (closure-parms-opnds parms)))
(univ-closure-alloc
ctx
lbl
(map (lambda (opnd)
(cond ((assv opnd rev-loc-names) => cdr)
((memv opnd (map closure-parms-loc lst))
(^bool #f))
(else
(^getopnd opnd))))
opnds)
(lambda (name)
(alloc (cdr lst)
(cons (cons loc name)
rev-loc-names)))))
(init (close-parms gvm-instr) (reverse rev-loc-names))))
(define (init lst loc-names)
(if (pair? lst)
(let* ((parms (car lst))
(loc (closure-parms-loc parms))
(opnds (closure-parms-opnds parms))
(loc-name (assv loc loc-names)))
(let loop ((i 1) ;; 0
(opnds opnds) ;; (cons (make-lbl lbl) opnds)
(rev-code '()))
(if (pair? opnds)
(let ((opnd (car opnds)))
(loop (+ i 1)
(cdr opnds)
(cons (if (and (assv opnd loc-names)
(memv opnd (map closure-parms-loc lst)))
(^setclo
(cdr loc-name)
i
(cdr (assv opnd loc-names)))
(^))
rev-code)))
(^ (reverse rev-code)
(init (cdr lst) loc-names)))))
(map
(lambda (loc-name)
(let* ((loc (car loc-name))
(name (cdr loc-name)))
(^setloc loc name)))
loc-names)))
(alloc (close-parms gvm-instr) '())))
((ifjump)
;; TODO
;; (ifjump-poll? gvm-instr)
(let ((test (ifjump-test gvm-instr))
(opnds (ifjump-opnds gvm-instr))
(true (ifjump-true gvm-instr))
(false (ifjump-false gvm-instr))
(fs (frame-size (gvm-instr-frame gvm-instr))))
(let ((proc (proc-obj-test test)))
(if (not proc)
(compiler-internal-error
"scan-gvm-instr, unknown 'test'" test)
(proc
ctx
(lambda (result)
(^if result
(jump-to-label ctx true fs)
(jump-to-label ctx false fs)))
opnds)))))
((switch)
;; TODO
;; (switch-opnd gvm-instr)
;; (switch-cases gvm-instr)
;; (switch-poll? gvm-instr)
;; (switch-default gvm-instr)
(univ-throw ctx "\"switch GVM instruction unimplemented\""))
((jump)
;; TODO
;; (jump-safe? gvm-instr)
;; test: (jump-poll? gvm-instr)
(let ((nb-args (jump-nb-args gvm-instr))
(poll? (jump-poll? gvm-instr))
(safe? (jump-safe? gvm-instr))
(opnd (jump-opnd gvm-instr))
(fs (frame-size (gvm-instr-frame gvm-instr))))
(or (and (obj? opnd)
(proc-obj? (obj-val opnd))
nb-args
(let* ((proc (obj-val opnd))
(jump-inliner (proc-obj-jump-inline proc)))
(and jump-inliner
(jump-inliner ctx nb-args poll? safe? fs))))
(^ (if nb-args
(^setnargs nb-args)
(^))
(or (and (lbl? opnd)
(not poll?)
(jump-to-label ctx (lbl-num opnd) fs))
(with-stack-pointer-adjust
ctx
(+ fs
(ctx-stack-base-offset ctx))
(lambda (ctx)
(^return-poll
(if (jump-safe? gvm-instr)
(if (glo? opnd)
(^call-prim
(^prefix (univ-use-rtlib ctx 'check_procedure_glo))
(scan-gvm-opnd ctx opnd)
(^obj (glo-name opnd)))
(^call-prim
(^prefix (univ-use-rtlib ctx 'check_procedure))
(scan-gvm-opnd ctx opnd)))
(scan-gvm-opnd ctx opnd))
poll?
(and
;; avoid call optimization on globals
;; because some VMs, such as V8 and PyPy,
;; use a counterproductive speculative
;; optimization (which slows
;; down fib by an order of magnitude!)
(not (reg? opnd))
(case (target-name (ctx-target ctx))
((php)
;; avoid call optimization on PHP
;; because it generates syntactically
;; incorrect code (PHP grammar issue)
#f)
(else
#t)))))))))))
(else
(compiler-internal-error
"scan-gvm-instr, unknown 'gvm-instr':"
gvm-instr))))
(define (jump-to-label ctx n jump-fs)
(cond ((and (ctx-allow-jump-destination-inlining? ctx)
(let* ((bb (lbl-num->bb n bbs))
(label-instr (bb-label-instr bb)))
(and (eq? (label-type label-instr) 'simple)
(or (= (length (bb-precedents bb)) 1)
(= (length (bb-non-branch-instrs bb)) 0))))) ;; very short destination bb?
(let* ((bb (lbl-num->bb n bbs))
(label-instr (bb-label-instr bb))
(label-fs (frame-size (gvm-instr-frame label-instr))))
(with-stack-pointer-adjust
ctx
(+ jump-fs
(ctx-stack-base-offset ctx))
(lambda (ctx)
(with-stack-base-offset
ctx
(- label-fs)
(lambda (ctx)
(with-allow-jump-destination-inlining?
ctx
(= (length (bb-precedents bb)) 1) ;; #f
(lambda (ctx)
(scan-bb-all-except-label ctx bb)))))))))
(else
(with-stack-pointer-adjust
ctx
(+ jump-fs
(ctx-stack-base-offset ctx))
(lambda (ctx)
(^return-call
(scan-gvm-opnd ctx (make-lbl n))))))))
(define (scan-gvm-opnd ctx gvm-opnd)
(if (lbl? gvm-opnd)
(todo-lbl-num! (lbl-num gvm-opnd)))
(^getopnd gvm-opnd));;;;;;;;;;;;;;;;;;;;;;;scan-gvm-loc ?
(todo-lbl-num! (bbs-entry-lbl-num bbs))
(let ((bbs-code
(let loop ((rev-res '()))
(if (queue-empty? bb-todo)
(reverse rev-res)
(loop (cons (scan-bb ctx (queue-get! bb-todo))
rev-res))))))
(^ bbs-code
(let* ((lbl
(make-lbl (bbs-entry-lbl-num bbs)))
(entry-id
(gvm-lbl-use ctx lbl))
(subprocs-array
(^array-literal
(map (lambda (n)
(univ-subproc-reference ctx n))
(stretchable-vector->list subprocs)))))
(if (univ-subproc-reference-as-string? ctx)
(begin
(set-car! subprocs-init subprocs-array)
(^))
(begin
(set-car! subprocs-init (^bool #f))
(^ "\n"
(univ-with-function-attribs
ctx
#f
entry-id
(lambda ()
(univ-set-function-attrib
ctx
entry-id
"subprocs"
subprocs-array)))))))
(let ((name (string->symbol (proc-obj-name p))))
(^ "\n"
(^setprm name (^obj p))
(if (proc-obj-primitive? p)
(^setglo name (^obj p))
(^))))))))
(let ((ctx (make-ctx
(ctx-target global-ctx)
(ctx-options global-ctx)
(ctx-module-ns global-ctx)
(proc-obj-name p)
(ctx-objs-used global-ctx)
(ctx-rtlib-features-used global-ctx)
(ctx-decls global-ctx))))
(^ "\n"
(univ-comment
ctx
(^ "-------------------------------- "
(if (proc-obj-primitive? p)
"primitive"
"procedure")
" "
(object->string (string->canonical-symbol (proc-obj-name p)))
" =\n"))
(let ((x (proc-obj-code p)))
(if (bbs? x)
(scan-bbs ctx x)
(^))))))
(for-each scan-obj procs)
(let loop ((rev-res '()))
(if (queue-empty? proc-left)
(reverse (append rev-res *constants*))
(loop (cons (dump-proc (queue-get! proc-left))
rev-res))))))
(define (univ-label-entry ctx gvm-instr id)
(let* ((nb-parms (label-entry-nb-parms gvm-instr))
(opts (label-entry-opts gvm-instr))
(keys (label-entry-keys gvm-instr))
(rest? (label-entry-rest? gvm-instr))
(closed? (label-entry-closed? gvm-instr))
(nb-parms-except-rest
(- nb-parms (if rest? 1 0)))
(nb-keys
(if keys (length keys) 0))
(nb-req-and-opt
(- nb-parms-except-rest nb-keys))
(nb-opts
(length opts))
(nb-req
(- nb-req-and-opt nb-opts))
(defaults
(append opts (map cdr (or keys '())))))
(define (dispatch-on-nb-args nb-args)
(if (> nb-args (- nb-req-and-opt (if rest? 0 1)))
(if keys
(compiler-internal-error
"univ-label-entry, keyword parameters not supported")
(^if (if rest?
(^not (^call-prim
(^prefix (univ-use-rtlib ctx 'build_rest))
nb-parms-except-rest))
(^!= (^getnargs)
nb-parms-except-rest))
(^return-call-prim
(^prefix (univ-use-rtlib ctx 'wrong_nargs))
(if closed?
(^getreg (+ univ-nb-arg-regs 1))
id))))
(let ((nb-stacked (max 0 (- nb-args univ-nb-arg-regs)))
(nb-stacked* (max 0 (- nb-parms univ-nb-arg-regs))))
(define (setup-parameter i)
(if (<= i nb-parms)
(let* ((rest (setup-parameter (+ i 1)))
(src-reg (- i nb-stacked))
(src (cond ((<= i nb-args)
(^getreg src-reg))
((and rest? (= i nb-parms))
(^obj '()))
(else
(^obj
(obj-val (list-ref defaults (- i nb-req 1))))))))
(if (<= i nb-stacked*)
(^ (^push src)
rest)
(if (and (<= i nb-args) (= nb-stacked nb-stacked*))
rest
(let ((dst-reg (- i nb-stacked*)))
(^ (^setreg dst-reg src)
rest)))))
(^)))
(let ((x (setup-parameter (+ nb-stacked 1))))
(^if (^= (^getnargs)
nb-args)
x
(dispatch-on-nb-args (+ nb-args 1)))))))
(dispatch-on-nb-args nb-req)))
(define closure-count 0)
(define (univ-separated-list sep lst)
(if (pair? lst)
(if (pair? (cdr lst))
(list (car lst) sep (univ-separated-list sep (cdr lst)))
(car lst))
'()))
(define (univ-map-index f lst)
(define (mp f lst i)
(if (pair? lst)
(cons (f (car lst) i)
(mp f (cdr lst) (+ i 1)))
'()))
(mp f lst 0))
(define (univ-closure-alloc ctx lbl exprs cont)
(let ((count (ctx-serial-num ctx)))
(ctx-serial-num-set! ctx (+ count 1))
(let ((name (^local-var (^ "closure" count))))
(^ (^var-declaration
name
(^call-prim
(^prefix (univ-use-rtlib ctx 'closure_alloc))
(^array-literal
(cons (gvm-lbl-use ctx (make-lbl lbl))
exprs))))
(cont name)))))
(define (make-ctx target options module-ns ns objs-used rtlib-features-used decls)
(vector target
options
module-ns
ns
0
0
univ-enable-jump-destination-inlining?
(make-resource-set)
(make-resource-set)
(make-resource-set)
objs-used
rtlib-features-used
decls))
(define (ctx-target ctx) (vector-ref ctx 0))
(define (ctx-target-set! ctx x) (vector-set! ctx 0 x))
(define (ctx-options ctx) (vector-ref ctx 1))
(define (ctx-options-set! ctx x) (vector-set! ctx 1 x))
(define (ctx-module-ns ctx) (vector-ref ctx 2))
(define (ctx-module-ns-set! ctx x) (vector-set! ctx 2 x))
(define (ctx-ns ctx) (vector-ref ctx 3))
(define (ctx-ns-set! ctx x) (vector-set! ctx 3 x))
(define (ctx-stack-base-offset ctx) (vector-ref ctx 4))
(define (ctx-stack-base-offset-set! ctx x) (vector-set! ctx 4 x))
(define (ctx-serial-num ctx) (vector-ref ctx 5))
(define (ctx-serial-num-set! ctx x) (vector-set! ctx 5 x))
(define (ctx-allow-jump-destination-inlining? ctx) (vector-ref ctx 6))
(define (ctx-allow-jump-destination-inlining?-set! ctx x) (vector-set! ctx 6 x))
(define (ctx-resources-used-rd ctx) (vector-ref ctx 7))
(define (ctx-resources-used-rd-set! ctx x) (vector-set! ctx 7 x))
(define (ctx-resources-used-wr ctx) (vector-ref ctx 8))
(define (ctx-resources-used-wr-set! ctx x) (vector-set! ctx 8 x))
(define (ctx-globals-used ctx) (vector-ref ctx 9))
(define (ctx-globals-used-set! ctx x) (vector-set! ctx 9 x))
(define (ctx-objs-used ctx) (vector-ref ctx 10))
(define (ctx-objs-used-set! ctx x) (vector-set! ctx 10 x))
(define (ctx-rtlib-features-used ctx) (vector-ref ctx 11))
(define (ctx-rtlib-features-used-set! ctx x) (vector-set! ctx 11 x))
(define (ctx-decls ctx) (vector-ref ctx 12))
(define (ctx-decls-set! ctx x) (vector-set! ctx 12 x))
(define (with-stack-base-offset ctx n proc)
(let ((save (ctx-stack-base-offset ctx)))
(ctx-stack-base-offset-set! ctx n)
(let ((result (proc ctx)))
(ctx-stack-base-offset-set! ctx save)
result)))
(define (with-stack-pointer-adjust ctx n proc)
(^ (if (equal? n 0)
(^)
(^inc-by (gvm-state-sp-use ctx 'rdwr)
n))
(with-stack-base-offset
ctx
(- (ctx-stack-base-offset ctx) n)
proc)))
(define (with-allow-jump-destination-inlining? ctx allow? proc)
(let ((save (ctx-allow-jump-destination-inlining? ctx)))
(ctx-allow-jump-destination-inlining?-set! ctx allow?)
(let ((result (proc ctx)))
(ctx-allow-jump-destination-inlining?-set! ctx save)
result)))
(define (with-new-resources-used ctx proc)
(let ((save-rsrc-rd (ctx-resources-used-rd ctx))
(save-rsrc-wr (ctx-resources-used-wr ctx))
(save-glob-rd (ctx-globals-used ctx)))
(ctx-resources-used-rd-set! ctx (make-resource-set))
(ctx-resources-used-wr-set! ctx (make-resource-set))
(ctx-globals-used-set! ctx (make-resource-set))
(let ((result (proc ctx)))
(ctx-resources-used-rd-set! ctx save-rsrc-rd)
(ctx-resources-used-wr-set! ctx save-rsrc-wr)
(ctx-globals-used-set! ctx save-glob-rd)
result)))
(define (make-resource-set)
(make-table))
(define (resource-set-add! set element)
(table-set! set element #t))
(define (resource-set-member? set element)
(table-ref set element #f))
(define (resource-set->list set)
(map car (table->list set)))
(define (use-resource-rd ctx resource)
(resource-set-add! (ctx-resources-used-rd ctx) resource))
(define (use-resource-wr ctx resource)
(resource-set-add! (ctx-resources-used-wr ctx) resource))
(define (use-global ctx global)
(resource-set-add! (ctx-globals-used ctx) global))
(define (univ-use-rtlib ctx feature)
(resource-set-add! (ctx-rtlib-features-used ctx) feature)
(symbol->string feature))
(define (use-resource ctx dir resource)
(if (or (eq? dir 'rd) (eq? dir 'rdwr))
(use-resource-rd ctx resource))
(if (or (eq? dir 'wr) (eq? dir 'rdwr))
(use-resource-wr ctx resource)))
(define (gvm-state-pollcount ctx)
(^global-var (^prefix 'pollcount)))
(define (gvm-state-nargs ctx)
(^global-var (^prefix 'nargs)))
(define (gvm-state-reg ctx num)
(^global-var (^prefix (^ 'r num))))
(define (gvm-state-stack ctx)
(^global-var (^prefix 'stack)))
(define (gvm-state-sp ctx)
(^global-var (^prefix 'sp)))
(define (gvm-state-cst ctx)
(^global-var (^prefix (^ 'cst_ (scheme-id->c-id (ctx-module-ns ctx))))))
(define (gvm-state-prm ctx)
(^global-var (^prefix 'prm)))
(define (gvm-state-glo ctx)
(^global-var (^prefix 'glo)))
(define (gvm-state-pollcount-use ctx dir)
(use-resource ctx dir 'pollcount)
(gvm-state-pollcount ctx))
(define (gvm-state-nargs-use ctx dir)
(use-resource ctx dir 'nargs)
(gvm-state-nargs ctx))
(define (gvm-state-reg-use ctx dir num)
(use-resource ctx dir num)
(gvm-state-reg ctx num))
(define (gvm-state-stack-use ctx dir)
(use-resource ctx dir 'stack)
(gvm-state-stack ctx))
(define (gvm-state-sp-use ctx dir)
(use-resource ctx dir 'sp)
(gvm-state-sp ctx))
(define (gvm-state-prm-use ctx dir)
(use-resource ctx dir 'prm)
(gvm-state-prm ctx))
(define (gvm-state-glo-use ctx dir)
(use-resource ctx dir 'glo)
(gvm-state-glo ctx))
(define (univ-emit-tos ctx)
(^array-index
(gvm-state-stack-use ctx 'rd)
(gvm-state-sp-use ctx 'rd)))
(define (univ-emit-pop ctx receiver)
(^ (receiver (^tos))
(^inc-by (gvm-state-sp-use ctx 'rdwr)
-1)))
(define (univ-emit-push ctx val)
(^inc-by (gvm-state-sp-use ctx 'rdwr)
1
(lambda (x)
(^assign
(^array-index
(gvm-state-stack-use ctx 'rd)
x)
val))))
(define (univ-emit-getnargs ctx)
(gvm-state-nargs-use ctx 'rd))
(define (univ-emit-setnargs ctx nb-args)
(^assign
(gvm-state-nargs-use ctx 'wr)
nb-args))
(define (univ-emit-getreg ctx num)
(gvm-state-reg-use ctx 'rd num))
(define (univ-emit-setreg ctx num val)
(^assign
(gvm-state-reg-use ctx 'wr num)
val))
(define (univ-stk-slot-from-tos ctx offset)
(^array-index
(gvm-state-stack-use ctx 'rd)
(^- (gvm-state-sp-use ctx 'rd)
offset)))
(define (univ-stk-location ctx offset)
(^array-index
(gvm-state-stack-use ctx 'rd)
(^ (gvm-state-sp-use ctx 'rd)
(cond ((= offset 0)
(^))
((< offset 0)
(^ offset))
(else
(^ "+" offset))))))
(define (univ-emit-getstk ctx offset)
(univ-stk-location ctx offset))
(define (univ-emit-setstk ctx offset val)
(^assign
(univ-stk-location ctx offset)
val))
(define (univ-clo-slots ctx closure)
(case (univ-procedure-representation ctx)
((class)
(^member closure 'slots))
(else
(case (target-name (ctx-target ctx))
((php)
(^member closure 'slots))
(else
(^call closure (^bool #t)))))))
(define (univ-emit-getclo ctx closure index)
(^closure-ref closure index))
(define (univ-emit-setclo ctx closure index val)
(^closure-set! closure index val))
(define (univ-prm-location ctx name)
(^prop-index
(gvm-state-prm-use ctx 'rd)
(^str (symbol->string name))))
(define (univ-glo-location ctx name)
(if (member name
'(println
real-time-milliseconds))
(univ-use-rtlib
ctx
(string->symbol (string-append "glo-" (symbol->string name)))))
(^prop-index
(gvm-state-glo-use ctx 'rd)
(^str (symbol->string name))))
(define (univ-emit-getprm ctx name)
(univ-prm-location ctx name))
(define (univ-emit-setprm ctx name val)
(^assign
(univ-prm-location ctx name)
val))
(define (univ-emit-getglo ctx name)
(univ-glo-location ctx name))
(define (univ-emit-setglo ctx name val)
(^assign
(univ-glo-location ctx name)
val))
(define (univ-glo-location-dynamic ctx sym)
(^prop-index
(gvm-state-glo-use ctx 'rd)
(^symbol-unbox sym)))
(define (univ-glo-primitive-location-dynamic ctx sym)
(^prop-index
(gvm-state-prm-use ctx 'rd)
(^symbol-unbox sym)))
(define (univ-emit-glo-var-ref ctx sym)
(univ-glo-location-dynamic ctx sym))
(define (univ-emit-glo-var-primitive-ref ctx sym)
(univ-glo-primitive-location-dynamic ctx sym))
(define (univ-emit-glo-var-set! ctx sym val)
(^assign
(univ-glo-location-dynamic ctx sym)
val))
(define (univ-emit-glo-var-primitive-set! ctx sym val)
(^assign
(univ-glo-primitive-location-dynamic ctx sym)
val))
(define (univ-emit-getopnd ctx gvm-opnd)
(cond ((reg? gvm-opnd)
(^getreg (reg-num gvm-opnd)))
((stk? gvm-opnd)
(^getstk (+ (stk-num gvm-opnd) (ctx-stack-base-offset ctx))))
((glo? gvm-opnd)
(^getglo (glo-name gvm-opnd)))
((clo? gvm-opnd)
(^getclo (^getopnd (clo-base gvm-opnd))
(clo-index gvm-opnd)))
((lbl? gvm-opnd)
(gvm-lbl-use ctx gvm-opnd))
((obj? gvm-opnd)
(^obj (obj-val gvm-opnd)))
(else
(compiler-internal-error
"univ-emit-getopnd, unknown 'gvm-opnd':"
gvm-opnd))))
(define (univ-emit-getopnds ctx gvm-opnds)
(map (lambda (gvm-opnd) (univ-emit-getopnd ctx gvm-opnd))
gvm-opnds))
(define (univ-emit-setloc ctx gvm-loc val)
(cond ((reg? gvm-loc)
(^setreg (reg-num gvm-loc)
val))
((stk? gvm-loc)
(^setstk (+ (stk-num gvm-loc) (ctx-stack-base-offset ctx))
val))
((glo? gvm-loc)
(^setglo (glo-name gvm-loc)
val))
((clo? gvm-loc)
(^setclo (^getopnd (clo-base gvm-loc))
(clo-index gvm-loc)
val))
(else
(compiler-internal-error
"univ-emit-setloc, unknown 'gvm-loc':"
gvm-loc))))
(define (univ-emit-obj ctx obj)
(define (emit-obj obj force-var?)
(cond ((or (false-object? obj)
(boolean? obj))
(^boolean-obj obj))
((number? obj)
(cond ((not (real? obj)) ;; non-real complex number
(univ-obj-use
ctx
obj
force-var?
(lambda ()
(^cpxnum-make (emit-obj (real-part obj) #f)
(emit-obj (imag-part obj) #f)))))
((not (exact? obj)) ;; floating-point number
(let ((x (^float obj)))
(univ-box
(univ-obj-use
ctx
obj
force-var?
(lambda ()
(^flonum-box x)))
x)))
((not (integer? obj)) ;; non-integer rational number
(univ-obj-use
ctx
obj
force-var?
(lambda ()
(^ratnum-make (emit-obj (numerator obj) #f)
(emit-obj (denominator obj) #f)))))
(else ;; exact integer
(if (and (>= obj univ-fixnum-min)
(<= obj univ-fixnum-max))
(^fixnum-box (^int obj))
(univ-obj-use
ctx
obj
force-var?
(lambda ()
(^new (^prefix-class (univ-use-rtlib ctx 'Bignum))
(^array-literal
(univ-bignum-digits obj)))))))))
((char? obj)
(^char-obj obj force-var?))
((string? obj)
(^string-obj obj force-var?))
((symbol-object? obj)
(^symbol-obj obj force-var?))
((keyword-object? obj)
(^keyword-obj obj force-var?))
((null? obj)
(^null))
((void-object? obj)
(^void))
((end-of-file-object? obj)
(^eof))
((absent-object? obj)
(^absent))
((unbound1-object? obj)
(^unbound1))
((unbound2-object? obj)
(^unbound2))
((optional-object? obj)
(^optional))
((key-object? obj)
(^key))
((rest-object? obj)
(^rest))
((proc-obj? obj)
(^global-function (^prefix (gvm-proc-use ctx (proc-obj-name obj)))))
((pair? obj)
(univ-obj-use
ctx
obj
force-var?
(lambda ()
(^cons (emit-obj (car obj) #f)
(emit-obj (cdr obj) #f)))))
((vector-object? obj)
(univ-obj-use
ctx
obj
force-var?
(lambda ()
(^vector-box
(^array-literal
(map (lambda (x) (emit-obj x #f))
(vector->list obj)))))))
((u8vect? obj)
(univ-obj-use
ctx
obj
force-var?
(lambda ()
(^u8vector-box
(^array-literal
(map (lambda (x) (emit-obj x #f))
(u8vect->list obj)))))))
((u16vect? obj)
(univ-obj-use
ctx
obj
force-var?
(lambda ()
(^u16vector-box
(^array-literal
(map (lambda (x) (emit-obj x #f))
(u16vect->list obj)))))))
((f64vect? obj)
(univ-obj-use
ctx
obj
force-var?
(lambda ()
(^f64vector-box
(^array-literal
(map (lambda (x) (emit-obj x #f))
(f64vect->list obj)))))))
((structure-object? obj)
(univ-obj-use
ctx
obj
force-var?
(lambda ()
(let* ((slots
(##vector-copy obj));;TODO: replace call of ##vector-copy
(cyclic?
(eq? (vector-ref slots 0) obj)))
;; the root type descriptor is cyclic, handle this specially
(if cyclic?
(vector-set! slots 0 #f))
(^structure-box
(^array-literal
(map (lambda (x) (emit-obj x #f))
(vector->list slots))))))))
(else
(compiler-user-warning #f "UNIMPLEMENTED OBJECT:" obj)
(^str
(string-append
"UNIMPLEMENTED OBJECT: "
(object->string obj))))))
(emit-obj obj #t))
(define univ-adigit-width 14)
(define (univ-bignum-digits obj)
(define (dig n len rest)
(cond ((= len 1)
(cons n rest))
(else
(let* ((hi-len (quotient len 2))
(lo-len (- len hi-len))
(lo-len-bits (* univ-adigit-width lo-len)))
(let* ((hi (arithmetic-shift n (- lo-len-bits)))
(lo (- n (arithmetic-shift hi lo-len-bits))))
(dig lo
lo-len
(dig hi
hi-len
rest)))))))
(let* ((width (integer-length obj))
(len (+ (quotient width univ-adigit-width) 1)))
(dig (if (< obj 0)
(+ (arithmetic-shift 1 (* univ-adigit-width len)) obj)
obj)
len
'())))
(define (univ-emit-array-literal ctx elems)
(case (target-name (ctx-target ctx))
((js python ruby)
(^ "[" (univ-separated-list "," elems) "]"))
((php)
(^apply "array" elems))
(else
(compiler-internal-error
"univ-emit-array-literal, unknown target"))))
(define (univ-emit-extensible-array-literal ctx elems)
(case (target-name (ctx-target ctx))
((js ruby)
(^ "[" (univ-separated-list "," elems) "]"))
((php)
(^apply "array" elems))
((python)
(let ((key-vals
(let loop ((i 0) (lst elems) (rev-kv '()))
(if (pair? lst)
(loop (+ i 1)
(cdr lst)
(cons (^ i ":" (car lst)) rev-kv))
(reverse rev-kv)))))
(^ "{" (univ-separated-list "," key-vals) "}")))
(else
(compiler-internal-error
"univ-emit-extensible-array-literal, unknown target"))))
(define (univ-new-array ctx len)
(case (target-name (ctx-target ctx))
((js)
(^new "Array" len))
((php)
(^if-expr (^= len (^int 0)) ;; array_fill does not like len=0
(^array-literal '())
(^call-prim
"array_fill"
(^int 0)
len
(^int 0))))
((python)
(^* (^ "[" (^int 0) "]") len))
((ruby)
(^call-prim (^member "Array" 'new) len))
(else
(compiler-internal-error
"univ-new-array, unknown target"))))
(define (univ-make-array ctx return len init)
(case (target-name (ctx-target ctx))
((js)
;; TODO: add for loop constructor
(let ((elems (^local-var 'elems)))
(^ (^var-declaration elems (^new "Array" len))
"
for (var i=0; i<" len "; i++) {
" elems "[i] = " init ";
}
"
(return elems))))
((php)
(return
(^if-expr (^= len (^int 0)) ;; array_fill does not like len=0
(^array-literal '())
(^call-prim
"array_fill"
(^int 0)
len
init))))
((python)
;; TODO: add literal array constructor
(return
(^* (^ "[" init "]") len)))
((ruby)
(return
(^call-prim (^member "Array" 'new) len init)))
(else
(compiler-internal-error
"univ-make-array, unknown target"))))
(define (univ-emit-empty-dict ctx)
(case (target-name (ctx-target ctx))
((js python ruby)
(^ "{}"))
((php)
(^ "array()"))
(else
(compiler-internal-error
"univ-emit-empty-dict, unknown target"))))
;;==================================================================
(define *constants* '());;;TODO: remove
;; =============================================================================
(define (gvm-lbl-use ctx lbl)
(^global-function (gvm-lbl-use-function ctx lbl)))
(define (gvm-lbl-use-function ctx lbl)
(^prefix (gvm-bb-use ctx (lbl-num lbl) (ctx-ns ctx))))
(define (gvm-proc-use ctx name)
(gvm-bb-use ctx 1 name))
(define (gvm-bb-use ctx num ns)
(let ((id (lbl->id ctx num ns)))
(use-global ctx (^global-function (^prefix id)))
id))
(define (lbl->id ctx num ns)
(^ "bb" num "_" (scheme-id->c-id ns)))
(define (univ-foldr-range lo hi rest fn)
(if (<= lo hi)
(univ-foldr-range
lo
(- hi 1)
(fn hi rest)
fn)
rest))
(define (univ-emit-continuation-capture-function ctx nb-args thread-save?)
(let ((nb-stacked (max 0 (- nb-args univ-nb-arg-regs))))
(^procedure-declaration
#t
(^ (if thread-save?
"thread_save"
"continuation_capture")
nb-args)
'()
"\n"
'()
(^ (if (= nb-stacked 0)
(^var-declaration (^local-var (^ 'arg 1)) (^getreg 1))
(univ-foldr-range
1
nb-stacked
(^)
(lambda (i rest)
(^ rest
(^pop (lambda (expr)
(^var-declaration (^local-var (^ 'arg i))
expr)))))))
(^setreg 0
(^call-prim
(^prefix (univ-use-rtlib ctx 'heapify))
(^getreg 0)))
(let* ((cont
(^new (^prefix-class (univ-use-rtlib ctx 'Continuation))
(^array-index
(gvm-state-stack-use ctx 'rd)
0)
(^structure-ref (^gvar 'current_thread)
univ-thread-denv-slot)))
(result
(if thread-save?
(^gvar 'current_thread)
cont)))
(^ (if thread-save?
(^structure-set! (^gvar 'current_thread)
univ-thread-cont-slot
cont)
(^))
(if (= nb-stacked 0)
(^setreg 1 result)
(univ-foldr-range
1
nb-stacked
(^)
(lambda (i rest)
(^ (^push (if (= i 1) result (^local-var (^ 'arg i))))
rest))))))
(^setnargs nb-args)
(^return-call (^local-var (^ 'arg 1)))))))
(define (univ-emit-continuation-graft-no-winding-function ctx nb-args thread-restore?)
(^procedure-declaration
#t
(^ (if thread-restore?
"thread_restore"
"continuation_graft_no_winding")
nb-args)
'()
"\n"
'()
(let* ((nb-stacked
(max 0 (- nb-args univ-nb-arg-regs)))
(new-nb-args
(- nb-args 2))
(new-nb-stacked
(max 0 (- new-nb-args univ-nb-arg-regs)))
(underflow
(^gvar (univ-use-rtlib ctx 'underflow))))
(^ (univ-foldr-range
1
(max 2 (- nb-args univ-nb-arg-regs))
(^)
(lambda (i rest)
(^ rest
(^var-declaration
(^local-var (^ 'arg i))
(let ((x (- i nb-stacked)))
(if (>= x 1)
(^getreg x)
(^getstk x)))))))
(if thread-restore?
(^ (^assign (^gvar 'current_thread)
(^local-var (^ 'arg 1)))
(^assign (^local-var (^ 'arg 1))
(^structure-ref (^local-var (^ 'arg 1))
univ-thread-cont-slot)))
(^))
(^assign
(^array-index
(gvm-state-stack-use ctx 'rd)
0)
(^member (^local-var (^ 'arg 1)) 'frame))
(^structure-set! (^gvar 'current_thread)
univ-thread-denv-slot
(^member (^local-var (^ 'arg 1)) 'denv))
(^assign
(gvm-state-sp-use ctx 'wr)
0)
(^setreg 0 underflow)
(univ-foldr-range
1
new-nb-stacked
(^)
(lambda (i rest)
(^ (^push (^local-var (^ 'arg (+ i 2))))
rest)))
(if (= new-nb-stacked (- nb-stacked 2))
(^)
(univ-foldr-range
(+ new-nb-stacked 1)
new-nb-args
(^)
(lambda (i rest)
(^ (^setreg (- i new-nb-stacked)
(^getreg (- i (- nb-stacked 2))))
rest))))
(^setnargs new-nb-args)
(^return (^local-var (^ 'arg 2)))))))
(define (univ-emit-continuation-return-no-winding-function ctx nb-args)
(^procedure-declaration
#t
(^ "continuation_return_no_winding" nb-args)
'()
"\n"
'()
(let* ((nb-stacked
(max 0 (- nb-args univ-nb-arg-regs)))
(underflow
(^gvar (univ-use-rtlib ctx 'underflow)))
(arg1
(let ((x (- 1 nb-stacked)))
(if (>= x 1)
(^getreg x)
(^getstk x)))))
(^ (^assign
(^array-index
(gvm-state-stack-use ctx 'rd)
0)
(^member arg1 'frame))
(^structure-set! (^gvar 'current_thread)
univ-thread-denv-slot
(^member arg1 'denv))
(^assign
(gvm-state-sp-use ctx 'wr)
0)
(^setreg 0 underflow)
(let ((x (- 2 nb-stacked)))
(if (= x 1)
(^)
(^setreg 1 (^getreg x))))
(^return underflow)))))
(define (univ-emit-apply-function ctx nb-args)
(^procedure-declaration
#t
(^ "apply" nb-args)
'()
"\n"
'()
(^ (univ-pop-args-to-vars ctx nb-args)
(univ-foldr-range
2
(- nb-args 1)
(^)
(lambda (i rest)
(^ (^push (^local-var (^ 'arg i)))
rest)))
(^setnargs (- nb-args 2))
(let ((args (^local-var (^ 'arg nb-args))))
(^while (^pair? args)
(^ (^push (^getcar args))
(^assign args (^getcdr args))
(^inc-by (gvm-state-nargs-use ctx 'rdwr)
1))))
(univ-pop-args-to-regs ctx 0)
(^return (^local-var (^ 'arg 1))))))
(define (univ-pop-args-to-vars ctx nb-args)
(let ((nb-stacked (max 0 (- nb-args univ-nb-arg-regs))))
(univ-foldr-range
1
nb-args
(^)
(lambda (i rest)
(^ rest
(let ((x (- i nb-stacked)))
(if (>= x 1)
(^var-declaration (^local-var (^ 'arg i))
(^getreg x))
(^pop (lambda (expr)
(^var-declaration (^local-var (^ 'arg i))
expr))))))))))
(define (univ-push-args ctx)
(univ-foldr-range
0
(- univ-nb-arg-regs 1)
(^)
(lambda (i rest)
(^if (^> (^getnargs) i)
(^ (^push (^getreg (+ i 1)))
rest)))))
(define (univ-pop-args-to-regs ctx lo)
(univ-foldr-range
0
(- univ-nb-arg-regs 1)
(^)
(lambda (i rest)
(let ((x
(^ rest
(^pop (lambda (expr)
(^setreg (+ i 1) expr))))))
(if (< i lo)
x
(^if (^> (^getnargs) (- i lo))
x))))))
(define (univ-rtlib-feature ctx feature)
(case feature
((trampoline)
(^prim-function-declaration
"trampoline"
(list (cons 'pc #f))
"\n"
'()
(let ((pc (^local-var 'pc)))
(^while (^!= pc (^obj #f))
(^assign pc
(^call pc))))))
((heapify)
(^prim-function-declaration
"heapify"
(list (cons 'ra #f))
"\n"
'()
(^ (^if (^> (gvm-state-sp-use ctx 'rd) 0)
(univ-with-function-attribs
ctx
#f
(^local-var 'ra)
(lambda ()
(^ (^var-declaration
(^local-var 'fs)
(univ-get-function-attrib ctx (^local-var 'ra) 'fs))
(^var-declaration
(^local-var 'link)
(univ-get-function-attrib ctx (^local-var 'ra) 'link))
(^var-declaration
(^local-var 'base)
(^- (gvm-state-sp-use ctx 'rd)
(^local-var 'fs)))
(^extensible-array-to-array!
(gvm-state-stack-use ctx 'rdwr)
(^+ (gvm-state-sp-use ctx 'rd) 1))
(^var-declaration
(^local-var 'chain)
(gvm-state-stack-use ctx 'rd))
(^if (^> (^local-var 'base) 0)
(^ (^assign (^local-var 'chain)
(^subarray
(gvm-state-stack-use ctx 'rd)
(^local-var 'base)
(^+ (^local-var 'fs) 1)))
(^assign (^array-index
(^local-var 'chain)
0)
(^local-var 'ra))
(^assign (gvm-state-sp-use ctx 'wr)
(^local-var 'base))
(^var-declaration
(^local-var 'prev_frame)
(^alias (^local-var 'chain)))
(^var-declaration
(^local-var 'prev_link)
(^local-var 'link))
(^assign (^local-var 'ra)
(^array-index
(^local-var 'prev_frame)
(^local-var 'prev_link)))
(univ-with-function-attribs
ctx
#t
(^local-var 'ra)
(lambda ()
(^ (^assign
(^local-var 'fs)
(univ-get-function-attrib ctx (^local-var 'ra) 'fs))
(^assign
(^local-var 'link)
(univ-get-function-attrib ctx (^local-var 'ra) 'link))
(^assign
(^local-var 'base)
(^- (gvm-state-sp-use ctx 'rd)
(^local-var 'fs)))
(^while (^> (^local-var 'base) 0)
(^ (^var-declaration
(^local-var 'frame)
(^subarray
(gvm-state-stack-use ctx 'rd)
(^local-var 'base)
(^+ (^local-var 'fs) 1)))
(^assign
(^array-index
(^local-var 'frame)
0)
(^local-var 'ra))
(^assign
(gvm-state-sp-use ctx 'wr)
(^local-var 'base))
(^assign
(^array-index
(^local-var 'prev_frame)
(^local-var 'prev_link))
(^alias (^local-var 'frame)))
(^assign
(^local-var 'prev_frame)
(^alias (^local-var 'frame)))
(^unalias (^local-var 'frame))
(^assign
(^local-var 'prev_link)
(^local-var 'link))
(^assign
(^local-var 'ra)
(^array-index
(^local-var 'prev_frame)
(^local-var 'prev_link)))
(univ-with-function-attribs
ctx
#t
(^local-var 'ra)
(lambda ()
(^ (^assign
(^local-var 'fs)
(univ-get-function-attrib ctx (^local-var 'ra) 'fs))
(^assign
(^local-var 'link)
(univ-get-function-attrib ctx (^local-var 'ra) 'link))
(^assign
(^local-var 'base)
(^- (gvm-state-sp-use ctx 'rd)
(^local-var 'fs))))))))
(^assign
(^array-index
(gvm-state-stack-use ctx 'rd)
(^local-var 'link))
(^array-index
(gvm-state-stack-use ctx 'rd)
0))
(^assign
(^array-index
(gvm-state-stack-use ctx 'rd)
0)
(^local-var 'ra))
(^array-shrink!
(gvm-state-stack-use ctx 'rd)
(^+ (^local-var 'fs) 1))
(^assign
(^array-index
(^local-var 'prev_frame)
(^local-var 'prev_link))
(gvm-state-stack-use ctx 'rd))))))
(^ (^assign
(^array-index
(^local-var 'chain)
(^local-var 'link))
(^array-index
(^local-var 'chain)
0))
(^assign
(^array-index
(^local-var 'chain)
0)
(^local-var 'ra))))
(^assign
(gvm-state-stack-use ctx 'rd)
(^extensible-array-literal
(list (^local-var 'chain))))
(^assign
(gvm-state-sp-use ctx 'wr)
0)))))
(^return
(^gvar (univ-use-rtlib ctx 'underflow))))))
((underflow)
(^procedure-declaration
#t
"underflow"
'()
"\n"
(list (cons "fs" 0))
(^ (^var-declaration (^local-var 'frame)
(^array-index
(gvm-state-stack-use ctx 'rd)
0))
(^if (^eq? (^local-var 'frame) (^obj #f))
(^return (^obj #f)))
(^var-declaration (^local-var 'ra)
(^array-index
(^local-var 'frame)
0))
(univ-with-function-attribs
ctx
#f
(^local-var 'ra)
(lambda ()
(^ (^var-declaration (^local-var 'fs)
(univ-get-function-attrib ctx (^local-var 'ra) 'fs))
(^var-declaration (^local-var 'link)
(univ-get-function-attrib ctx (^local-var 'ra) 'link))
(^assign (gvm-state-stack-use ctx 'wr)
(^copy-array-to-extensible-array
(^local-var 'frame)
(^+ (^local-var 'fs) 1)))
(^assign (gvm-state-sp-use ctx 'wr)
(^local-var 'fs))
(^assign (^array-index
(gvm-state-stack-use ctx 'rd)
0)
(^alias
(^array-index
(^local-var 'frame)
(^local-var 'link))))
(^assign (^array-index
(gvm-state-stack-use ctx 'rd)
(^local-var 'link))
(^gvar (univ-use-rtlib ctx 'underflow))))))
(^return (^local-var 'ra)))))
((continuation_capture1)
(univ-emit-continuation-capture-function ctx 1 #f))
((continuation_capture2)
(univ-emit-continuation-capture-function ctx 2 #f))
((continuation_capture3)
(univ-emit-continuation-capture-function ctx 3 #f))
((continuation_capture4)
(univ-emit-continuation-capture-function ctx 4 #f))
((thread_save1)
(univ-emit-continuation-capture-function ctx 1 #t))
((thread_save2)
(univ-emit-continuation-capture-function ctx 2 #t))
((thread_save3)
(univ-emit-continuation-capture-function ctx 3 #t))
((thread_save4)
(univ-emit-continuation-capture-function ctx 4 #t))
((continuation_graft_no_winding2)
(univ-emit-continuation-graft-no-winding-function ctx 2 #f))
((continuation_graft_no_winding3)
(univ-emit-continuation-graft-no-winding-function ctx 3 #f))
((continuation_graft_no_winding4)
(univ-emit-continuation-graft-no-winding-function ctx 4 #f))
((continuation_graft_no_winding5)
(univ-emit-continuation-graft-no-winding-function ctx 5 #f))
((thread_restore2)
(univ-emit-continuation-graft-no-winding-function ctx 2 #t))
((thread_restore3)
(univ-emit-continuation-graft-no-winding-function ctx 3 #t))
((thread_restore4)
(univ-emit-continuation-graft-no-winding-function ctx 4 #t))
((thread_restore5)
(univ-emit-continuation-graft-no-winding-function ctx 5 #t))
((continuation_return_no_winding2)
(univ-emit-continuation-return-no-winding-function ctx 2))
((poll)
(^prim-function-declaration
"poll"
(list (cons 'dest #f))
"\n"
'()
(^ (^assign (gvm-state-pollcount-use ctx 'wr)
100)
(^return (^local-var 'dest)))))
((build_rest)
(^prim-function-declaration
"build_rest"
(list (cons 'nrp #f))
"\n"
'()
(^ (^var-declaration (^local-var 'rest) (^null))
(^if (^< (^getnargs)
(^local-var 'nrp))
(^return (^bool #f)))
(univ-push-args ctx)
(^while (^> (^getnargs)
(^local-var 'nrp))
(^ (^pop (lambda (expr)
(^assign (^local-var 'rest)
(^cons expr
(^local-var 'rest)))))
(^inc-by (gvm-state-nargs-use ctx 'rdwr)
-1)))
(^push (^local-var 'rest))
(univ-pop-args-to-regs ctx 1)
(^return (^bool #t)))))
((wrong_nargs)
(^prim-function-declaration
"wrong_nargs"
(list (cons 'proc #f))
"\n"
'()
(^ (^expr-statement
(^call-prim
(^prefix (univ-use-rtlib ctx 'build_rest))
0))
(^setreg 2 (^getreg 1))
(^setreg 1 (^local-var 'proc))
(^setnargs 2)
(^return (^getglo '##raise-wrong-number-of-arguments-exception)))))
((get)
#<<EOF
function gambit_get($obj,$name) {
return $obj[$name];
}
EOF
)
((set)
#<<EOF
function gambit_set(&$obj,$name,$val) {
$obj[$name] = $val;
}
EOF
)
((prepend_arg1)
(^prim-function-declaration
"prepend_arg1"
(list (cons 'arg1 #f))
"\n"
'()
(^ (^var-declaration (^local-var 'i) (^int 0))
(univ-push-args ctx)
(^push (^void))
(^while (^< (^local-var 'i) (^getnargs))
(^ (^assign (univ-stk-slot-from-tos ctx (^local-var 'i))
(univ-stk-slot-from-tos ctx (^parens (^+ (^local-var 'i) (^int 1)))))
(^inc-by (^local-var 'i)
1)))
(^assign (univ-stk-slot-from-tos ctx (^local-var 'i))
(^local-var 'arg1))
(^inc-by (gvm-state-nargs-use ctx 'rdwr)
1)
(univ-pop-args-to-regs ctx 0))))
((check_procedure_glo)
(^prim-function-declaration
"check_procedure_glo"
(list (cons 'dest #f)
(cons 'gv #f))
"\n"
'()
(^ (^if (^not (^parens (^procedure? (^local-var 'dest))))
(^ (^expr-statement
(^call-prim
(^prefix (univ-use-rtlib ctx 'prepend_arg1))
(^local-var 'gv)))
(^assign (^local-var 'dest)
(^getglo '##apply-global-with-procedure-check-nary))))
(^return (^local-var 'dest)))))
((check_procedure)
(^prim-function-declaration
"check_procedure"
(list (cons 'dest #f))
"\n"
'()
(^ (^if (^not (^parens (^procedure? (^local-var 'dest))))
(^ (^expr-statement
(^call-prim
(^prefix (univ-use-rtlib ctx 'prepend_arg1))
(^local-var 'dest)))
(^assign (^local-var 'dest)
(^getglo '##apply-with-procedure-check-nary))))
(^return (^local-var 'dest)))))
((make_subprocedure)
(^prim-function-declaration
"make_subprocedure"
(list (cons 'parent #f) (cons 'id #f))
"\n"
'()
(univ-with-function-attribs
ctx
#f
(^local-var 'parent)
(lambda ()
(^return
(univ-subproc-reference-to-subproc
ctx
(^array-index (univ-get-function-attrib ctx (^local-var 'parent) 'subprocs)
(^local-var 'id))))))))
((closure_alloc)
(case (univ-procedure-representation ctx)
((class)
(^prim-function-declaration
"closure_alloc"
(list (cons 'slots #f))
"\n"
'()
(^return (^new (^prefix-class (univ-use-rtlib ctx 'Closure))
(^local-var 'slots)))))
(else
(case (target-name (ctx-target ctx))
((php);;TODO: select call or __invoke
#<<EOF
class Gambit_Closure {
public function __construct($slots) {
$this->slots = $slots;
}
public function __invoke() {
global $gambit_r4;
$gambit_r4 = $this;
return $this->slots[0];
}
}
function gambit_closure_alloc($slots) {
return new Gambit_Closure($slots);
}
EOF
)
(else
(^prim-function-declaration
"closure_alloc"
(list (cons 'slots #f))
"\n"
'()
(let ((msg (^local-var 'msg))
(slots (^local-var 'slots))
(closure (^local-var 'closure)))
(^ (^procedure-declaration
#f
closure
(list (cons 'msg #t))
"\n"
'()
(^ (^if (^= msg (^bool #t))
(^return slots))
(^setreg (+ univ-nb-arg-regs 1) closure)
(^return (^array-index slots 0))))
(^return closure)))))))))
((make_closure)
(^prim-function-declaration
"make_closure"
(list (cons 'code #f)
(cons 'len #f))
"\n"
'()
(let ((code (^local-var 'code))
(len (^local-var 'len))
(slots (^local-var 'slots)))
(^ (^var-declaration slots
(univ-new-array ctx (^+ len (^int 1))))
(^assign (^array-index slots (^int 0)) code)
(^return
(^call-prim
(^prefix (univ-use-rtlib ctx 'closure_alloc))
slots))))))
((Procedure)
(^class-declaration
"Procedure"
#f
'()
'()))
((Closure)
(^class-declaration
"Closure"
(^prefix-class (univ-use-rtlib ctx 'Procedure))
'((slots . #f))
(list
(list 'call
'()
"\n"
(lambda (ctx)
(^ (^setreg (+ univ-nb-arg-regs 1) (^local-var (^this)))
(^return (^array-index (^this-member 'slots) 0))))))))
((Fixnum)
(^class-declaration
"Fixnum"
#f
'((val . #f))
'()))
((Flonum)
(^class-declaration
"Flonum"
#f
'((val . #f))
'()))
((Bignum)
(^class-declaration
"Bignum"
#f
'((digits . #f))
'()))
((bitcount)
(^prim-function-declaration
"bitcount"
(list (cons 'n #f))
"\n"
'()
(let ((n (^local-var 'n)))
(^ (^assign n (^+ (^parens (^bitand n
(^int #x55555555)))
(^parens (^bitand (^parens (^>> n (^int 1)))
(^int #x55555555)))))
(^assign n (^+ (^parens (^bitand n
(^int #x33333333)))
(^parens (^bitand (^parens (^>> n (^int 2)))
(^int #x33333333)))))
(^assign n (^bitand (^parens (^+ n (^parens (^>> n (^int 4)))))
(^int #x0f0f0f0f)))
(^assign n (^+ n (^parens (^>> n (^int 8)))))
(^assign n (^+ n (^parens (^>> n (^int 16)))))
(^return (^bitand n (^int #xff)))))))
((intlength)
(^prim-function-declaration
"intlength"
(list (cons 'n #f))
"\n"
'()
(let ((n (^local-var 'n)))
(^ (^if (^< n (^int 0)) (^assign n (^bitnot n)))
(^assign n (^bitior n (^parens (^>> n 1))))
(^assign n (^bitior n (^parens (^>> n 2))))
(^assign n (^bitior n (^parens (^>> n 4))))
(^assign n (^bitior n (^parens (^>> n 8))))
(^assign n (^bitior n (^parens (^>> n 16))))
(^return (^call-prim
(^prefix (univ-use-rtlib ctx 'bitcount))
n))))))
((bignum_make)
(^prim-function-declaration
"bignum_make"
(list (cons 'n #f) (cons 'x #f) (cons 'complement #f))
"\n"
'()
(let ((n (^local-var 'n))
(x (^local-var 'x))
(complement (^local-var 'complement))
(flip (^local-var 'flip))
(nbdig (^local-var 'nbdig))
(digits (^local-var 'digits))
(i (^local-var 'i)))
(^ (^var-declaration i
(^int 0))
(^var-declaration digits
(univ-new-array ctx n))
(^var-declaration nbdig
(^if-expr
(^eq? x (^obj #f))
(^int 0)
(^array-length (^member x 'digits))))
(^var-declaration flip
(^if-expr complement (^int 16383) (^int 0)))
(^if (^< n nbdig)
(^assign nbdig n))
(^while (^< i nbdig)
(^ (^assign (^array-index digits i)
(^bitxor (^array-index (^member x 'digits) i)
flip))
(^inc-by i 1)))
(^if (^and (^not (^parens (^eq? x (^obj #f))))
(^> (^array-index (^member x 'digits) (^- i (^int 1)))
(^int 8191)))
(^assign flip (^bitxor flip (^int 16383))))
(^while (^< i n)
(^ (^assign (^array-index digits i)
flip)
(^inc-by i 1)))
(^return
(^new (^prefix-class (univ-use-rtlib ctx 'Bignum))
digits))))))
((int2bignum)
(^prim-function-declaration
"int2bignum"
(list (cons 'n #f))
"\n"
'()
(let ((n (^local-var 'n))
(nbdig (^local-var 'nbdig))
(digits (^local-var 'digits))
(i (^local-var 'i)))
(^ (^var-declaration nbdig
(^+ (^parens
(univ-fxquotient
ctx
(^call-prim
(^prefix (univ-use-rtlib ctx 'intlength))
n)
(^int 14)))
(^int 1)))
(^var-declaration digits
(univ-new-array ctx nbdig))
(^var-declaration i
(^int 0))
(^while (^< i nbdig)
(^ (^assign (^array-index digits i)
(^bitand n (^int 16383)))
(^assign n
(^>> n (^int 14)))
(^inc-by i 1)))
(^return
(^new (^prefix-class (univ-use-rtlib ctx 'Bignum))
digits))))))
((Ratnum)
(^class-declaration
"Ratnum"
#f
'((num . #f) (den . #f))
'()))
((Cpxnum)
(^class-declaration
"Cpxnum"
#f
'((real . #f) (imag . #f))
'()))
((Pair)
(^class-declaration
"Pair"
#f
'((car . #f) (cdr . #f))
'()))
((Vector)
(^class-declaration
"Vector"
#f
'((elems . #f))
'()))
((U8Vector)
(^class-declaration
"U8Vector"
#f
'((elems . #f))
'()))
((U16Vector)
(^class-declaration
"U16Vector"
#f
'((elems . #f))
'()))
((F64Vector)
(^class-declaration
"F64Vector"
#f
'((elems . #f))
'()))
((Structure)
(^class-declaration
"Structure"
#f
'((slots . #f))
'()
(lambda (ctx)
(^if (^not (^array-index (^this-member 'slots) 0))
(^assign (^array-index (^this-member 'slots) 0)
(^local-var (^this)))))))
((Frame)
(^class-declaration
"Frame"
#f
'((slots . #f))
'()))
((Continuation)
(^class-declaration
"Continuation"
#f
'((frame . #f) (denv . #f))
'()))
((continuation_next)
(^prim-function-declaration
"continuation_next"
(list (cons 'cont #f))
"\n"
'()
(^ (^var-declaration (^local-var 'frame)
(^member (^local-var 'cont) 'frame))
(^var-declaration (^local-var 'denv)
(^member (^local-var 'cont) 'denv))
(^var-declaration (^local-var 'ra)
(^array-index (^local-var 'frame) 0))
(univ-with-function-attribs
ctx
#f
(^local-var 'ra)
(lambda ()
(^var-declaration (^local-var 'link)
(univ-get-function-attrib ctx (^local-var 'ra) 'link))))
(^var-declaration (^local-var 'next_frame)
(^array-index (^local-var 'frame)
(^local-var 'link)))
(^return
(^new (^prefix-class (univ-use-rtlib ctx 'Continuation))
(^local-var 'next_frame)
(^local-var 'denv))))))
((Symbol)
(^class-declaration
"Symbol"
#f
'((str . #f))
(list
(list (univ-tostr-method-name ctx)
'()
"\n"
(lambda (ctx)
(^return
(^this-member 'str)))))))
((make_interned_symbol)
(^ (^var-declaration (^gvar 'symbol_table) (^empty-dict))
"\n"
(^prim-function-declaration
"make_interned_symbol"
(list (cons 'str #f))
"\n"
'()
(^ (^var-declaration (^local-var 'sym)
(^prop-index (^gvar 'symbol_table)
(^local-var 'str)
(^bool #f)))
(^if (^not (^local-var 'sym))
(^ (^assign (^local-var 'sym)
(^symbol-box-uninterned (^local-var 'str)))
(^assign (^prop-index (^gvar 'symbol_table)
(^local-var 'str))
(^local-var 'sym))))
(^return (^local-var 'sym))))))
((Keyword)
(^class-declaration
"Keyword"
#f
'((str . #f))
(list
(list (univ-tostr-method-name ctx)
'()
"\n"
(lambda (ctx)
(^return
(^this-member 'str)))))))
((make_interned_keyword)
(^ (^var-declaration (^gvar 'keyword_table) (^empty-dict))
"\n"
(^prim-function-declaration
"make_interned_keyword"
(list (cons 'str #f))
"\n"
'()