437 lines
14 KiB
Racket
437 lines
14 KiB
Racket
;; constant construction code generator
|
|
;; (c) 1996-7 Sebastian Good
|
|
;; (c) 1997-8 PLT, Rice University
|
|
|
|
; Handles code-generation for constructing constants.
|
|
|
|
; Symbols and floating point numbers are handled specially,
|
|
; in a way that allows the generated C code to be both
|
|
; efficient and small.
|
|
; Other kinds of constants are constrcted by generating code
|
|
; that is prefixed onto the beginning of the program.
|
|
|
|
(module const mzscheme
|
|
(require mzlib/unit
|
|
mzlib/list
|
|
mzlib/etc)
|
|
|
|
(require syntax/zodiac-sig
|
|
syntax/stx)
|
|
|
|
(require "sig.ss")
|
|
(require "../sig.ss")
|
|
|
|
(provide const@)
|
|
(define-unit const@
|
|
(import (prefix compiler:option: compiler:option^)
|
|
compiler:library^
|
|
compiler:cstructs^
|
|
(prefix zodiac: zodiac^)
|
|
compiler:analyze^
|
|
compiler:zlayer^
|
|
compiler:vmstructs^
|
|
compiler:top-level^
|
|
compiler:driver^)
|
|
(export compiler:const^)
|
|
|
|
(define const:symbol-table (make-hash-table))
|
|
(define const:symbol-counter 0)
|
|
(define const:inexact-table (make-hash-table))
|
|
(define const:inexact-counter 0)
|
|
(define const:number-table (make-hash-table))
|
|
(define const:string-table (make-hash-table))
|
|
(define const:bytes-table (make-hash-table))
|
|
(define const:string-counter 0)
|
|
|
|
(define (const:get-symbol-table) const:symbol-table)
|
|
(define (const:get-symbol-counter) const:symbol-counter)
|
|
(define (const:get-inexact-table) const:inexact-table)
|
|
(define (const:get-inexact-counter) const:inexact-counter)
|
|
(define (const:get-string-table) const:string-table)
|
|
(define (const:get-bytes-table) const:bytes-table)
|
|
|
|
(define vector-table (make-hash-table))
|
|
|
|
(define compiler:static-list null)
|
|
(define compiler:per-load-static-list null)
|
|
|
|
(define (compiler:get-static-list) compiler:static-list)
|
|
(define (compiler:get-per-load-static-list) compiler:per-load-static-list)
|
|
|
|
(define new-uninterned-symbols null) ; list of (cons sym pos)
|
|
|
|
(define (const:init-tables!)
|
|
(set! const:symbol-table (make-hash-table))
|
|
(set! const:symbol-counter 0)
|
|
(set! const:inexact-table (make-hash-table))
|
|
(set! const:inexact-counter 0)
|
|
(set! const:number-table (make-hash-table))
|
|
(set! const:string-table (make-hash-table 'equal))
|
|
(set! const:bytes-table (make-hash-table 'equal))
|
|
(set! const:string-counter 0)
|
|
(set! compiler:static-list null)
|
|
(set! compiler:per-load-static-list null)
|
|
(set! vector-table (make-hash-table))
|
|
(set! new-uninterned-symbols null))
|
|
|
|
(define (const:intern-string s)
|
|
(let ([table
|
|
(if (string? s)
|
|
const:string-table
|
|
const:bytes-table)])
|
|
(hash-table-get
|
|
table
|
|
s
|
|
(lambda ()
|
|
(begin0
|
|
const:string-counter
|
|
(hash-table-put! table s const:string-counter)
|
|
(set! const:string-counter (add1 const:string-counter)))))))
|
|
|
|
(define (compiler:add-per-load-static-list! var)
|
|
(set! compiler:per-load-static-list
|
|
(cons var compiler:per-load-static-list)))
|
|
|
|
(define-values (const:the-per-load-statics-table
|
|
const:per-load-statics-table?)
|
|
(let-struct const:per-load-statics-table ()
|
|
(values (make-const:per-load-statics-table)
|
|
const:per-load-statics-table?)))
|
|
|
|
;; we need to make this in a-normalized, analyzed form from the beginning
|
|
(define compiler:add-const!
|
|
(lambda (code attr)
|
|
(let* ([var (gensym 'const)]
|
|
[sv (zodiac:make-top-level-varref
|
|
(zodiac:zodiac-stx code)
|
|
(make-empty-box)
|
|
var
|
|
#f
|
|
(box '())
|
|
#f
|
|
#f
|
|
#f)]
|
|
[def (zodiac:make-define-values-form
|
|
(zodiac:zodiac-stx code)
|
|
(make-empty-box) (list sv) code)])
|
|
|
|
(set-annotation! sv (varref:empty-attributes))
|
|
(varref:add-attribute! sv varref:static)
|
|
(varref:add-attribute! sv attr)
|
|
(cond
|
|
[(eq? attr varref:per-load-static)
|
|
(set! compiler:per-load-static-list
|
|
(cons var compiler:per-load-static-list))
|
|
(compiler:add-local-per-load-define-list! def)]
|
|
[else
|
|
(set! compiler:static-list (cons var compiler:static-list))
|
|
(compiler:add-local-define-list! def)])
|
|
sv)))
|
|
|
|
(define compiler:get-special-const!
|
|
(lambda (ast sym attrib table counter)
|
|
(let ([v (hash-table-get table sym (lambda () #f))])
|
|
(if v
|
|
(values v counter)
|
|
(let ([sv (zodiac:make-top-level-varref
|
|
(and ast (zodiac:zodiac-stx ast))
|
|
(make-empty-box)
|
|
(string->symbol (number->string counter))
|
|
#f
|
|
(box '())
|
|
#f
|
|
#f
|
|
#f)])
|
|
|
|
(set-annotation! sv (varref:empty-attributes))
|
|
(varref:add-attribute! sv attrib)
|
|
(varref:add-attribute! sv varref:static)
|
|
|
|
(hash-table-put! table sym sv)
|
|
(values sv (add1 counter)))))))
|
|
|
|
(define compiler:get-symbol-const!
|
|
(lambda (ast sym)
|
|
(let-values ([(sv c) (compiler:get-special-const! ast sym varref:symbol
|
|
const:symbol-table
|
|
const:symbol-counter)])
|
|
(when (c . > . const:symbol-counter)
|
|
(unless (eq? sym (string->symbol (symbol->string sym)))
|
|
(set! new-uninterned-symbols (cons
|
|
(cons sym const:symbol-counter)
|
|
new-uninterned-symbols)))
|
|
(set! const:symbol-counter c))
|
|
sv)))
|
|
|
|
(define (get-new-uninterned-symbols!)
|
|
(begin0
|
|
new-uninterned-symbols
|
|
(set! new-uninterned-symbols null)))
|
|
|
|
(define compiler:get-inexact-real-const!
|
|
(lambda (v ast)
|
|
(let ([sym (string->symbol (number->string v))])
|
|
(let-values ([(sv c) (compiler:get-special-const! ast sym varref:inexact
|
|
const:inexact-table
|
|
const:inexact-counter)])
|
|
(set! const:inexact-counter c)
|
|
sv))))
|
|
|
|
(define compiler:re-quote
|
|
(lambda (ast)
|
|
(zodiac:make-quote-form (zodiac:zodiac-stx ast)
|
|
(make-empty-box)
|
|
ast)))
|
|
|
|
;; [make this in analyzed form...]
|
|
(define compiler:make-const-constructor
|
|
(lambda (ast constructor-name args)
|
|
(let* ([v (zodiac:make-top-level-varref
|
|
;; FIXME?: wrong syntax
|
|
(zodiac:zodiac-stx ast)
|
|
(make-empty-box)
|
|
constructor-name
|
|
(module-path-index-join ''#%kernel #f)
|
|
(box '())
|
|
#f
|
|
#f
|
|
#f)]
|
|
[app (zodiac:make-app
|
|
(zodiac:zodiac-stx ast)
|
|
(make-empty-box)
|
|
v
|
|
args)])
|
|
(set-annotation! v (varref:empty-attributes))
|
|
(varref:add-attribute! v varref:primitive)
|
|
(set-annotation! app (make-app #f #t constructor-name))
|
|
(block:register-max-arity! (get-s:file-block) (length args))
|
|
(compiler:add-global-varref! v)
|
|
(compiler:add-primitive-varref! v)
|
|
app)))
|
|
|
|
(define ht-eol (gensym))
|
|
|
|
(define (get-hash-id elem)
|
|
(cond
|
|
[(zodiac:quote-form? elem) (let ([o (zodiac:quote-form-expr elem)])
|
|
(if (number? (zodiac:zread-object o))
|
|
(zodiac:zread-object o)
|
|
o))]
|
|
[else elem]))
|
|
|
|
(define (find-immutable-vector constructor elems)
|
|
(let ([ht (hash-table-get vector-table constructor (lambda () #f))])
|
|
(and ht
|
|
(let loop ([ht ht][l elems])
|
|
(if (null? l)
|
|
(hash-table-get ht ht-eol (lambda () #f))
|
|
(let ([ht (hash-table-get ht (get-hash-id (car l)) (lambda () #f))])
|
|
(and ht (loop ht (cdr l)))))))))
|
|
|
|
(define (remember-immutable-vector constructor elems const)
|
|
(let ([ht (hash-table-get vector-table constructor make-hash-table)])
|
|
(hash-table-put! vector-table constructor ht)
|
|
(let loop ([ht ht][l elems])
|
|
(if (null? l)
|
|
(hash-table-put! ht ht-eol const)
|
|
(let* ([hash-id (get-hash-id (car l))]
|
|
[htn (hash-table-get ht hash-id make-hash-table)])
|
|
(hash-table-put! ht hash-id htn)
|
|
(loop htn (cdr l)))))))
|
|
|
|
(define (construct-vector-constant ast constructor known-immutable?)
|
|
(let* ([elems (map (lambda (x)
|
|
(compiler:construct-const-code!
|
|
(zodiac:make-zread x)
|
|
known-immutable?))
|
|
(let ([p (zodiac:zodiac-stx ast)])
|
|
(or (syntax->list p)
|
|
(and (vector? (syntax-e p))
|
|
(vector->list (syntax-e p)))
|
|
(and (or (regexp? (syntax-e p))
|
|
(byte-regexp? (syntax-e p)))
|
|
(list (datum->syntax-object #f (object-name (syntax-e p)))))
|
|
(let loop ([p p])
|
|
(cond
|
|
[(stx-pair? p)
|
|
(cons (stx-car p)
|
|
(loop (stx-cdr p)))]
|
|
[else
|
|
(list p)])))))]
|
|
[known-immutable? (or known-immutable? (null? elems))])
|
|
(or (and known-immutable?
|
|
(find-immutable-vector constructor elems))
|
|
(let ([const (compiler:add-const!
|
|
(compiler:make-const-constructor
|
|
ast
|
|
constructor
|
|
elems)
|
|
(if known-immutable?
|
|
varref:static
|
|
varref:per-load-static))])
|
|
(when known-immutable?
|
|
(remember-immutable-vector constructor elems const))
|
|
const))))
|
|
|
|
(define (big-and-simple/cyclic? datum size ht)
|
|
(cond
|
|
[(null? datum) (negative? size)]
|
|
[(hash-table-get ht datum (lambda () #f)) 'cyclic]
|
|
[(pair? datum)
|
|
(hash-table-put! ht datum #t)
|
|
(let ([v (big-and-simple/cyclic? (car datum) 0 ht)])
|
|
(if (eq? v 'cyclic)
|
|
'cyclic
|
|
(let ([v2 (big-and-simple/cyclic? (cdr datum) (sub1 size) ht)])
|
|
(if (eq? v2 'cyclic)
|
|
'cyclic
|
|
(and v v2)))))]
|
|
[(vector? datum)
|
|
(let ([len (vector-length datum)])
|
|
(and (hash-table-put! ht datum #t)
|
|
(let loop ([i 0][so-far? #f])
|
|
(if (= i len)
|
|
so-far?
|
|
(let ([v (big-and-simple/cyclic? (vector-ref datum i) (- size i) ht)])
|
|
(if (eq? v 'cyclic)
|
|
'cyclic
|
|
(loop (add1 i) (or so-far? v))))))))]
|
|
[(hash-table? datum) 'cyclic] ;; assume content is ok and cyclic
|
|
[(and (negative? size)
|
|
(or (number? datum)
|
|
(string? datum)
|
|
(bytes? datum)
|
|
(symbol? datum)
|
|
(boolean? datum)
|
|
(regexp? datum)
|
|
(byte-regexp? datum)))
|
|
#t]
|
|
[else #f]))
|
|
|
|
(define-struct compiled-string (id len))
|
|
|
|
(define (construct-big-constant ast stx known-immutable?)
|
|
(let* ([s (let ([p (open-output-bytes)])
|
|
(write (compile `(quote ,stx)) p)
|
|
(get-output-bytes p))]
|
|
[id (const:intern-string s)])
|
|
(let ([const (compiler:add-const!
|
|
(compiler:re-quote
|
|
(zodiac:make-zread
|
|
(datum->syntax-object
|
|
#f
|
|
;; HACK!
|
|
(make-compiled-string id (bytes-length s)))))
|
|
(if known-immutable?
|
|
varref:static
|
|
varref:per-load-static))])
|
|
const)))
|
|
|
|
(define compiler:construct-const-code!
|
|
(lambda (ast known-immutable?)
|
|
(cond
|
|
;; base case - constant does not have to be built
|
|
[(vm:literal-constant? ast) (compiler:re-quote ast)]
|
|
|
|
;; c-lambda (kindof a hack)
|
|
[(c-lambda? ast)
|
|
(compiler:add-const! (compiler:re-quote
|
|
(zodiac:make-zread
|
|
(datum->syntax-object
|
|
#f
|
|
ast ;; See vm2c.ss
|
|
#f)))
|
|
varref:static)]
|
|
|
|
;; a box has a constant inside it to mess with, yet it's
|
|
;; still a scalar
|
|
[(box? (zodiac:zread-object ast))
|
|
(compiler:add-const! (compiler:make-const-constructor
|
|
ast
|
|
'box
|
|
(list (compiler:construct-const-code!
|
|
(zodiac:make-zread (unbox (zodiac:zread-object ast)))
|
|
known-immutable?)))
|
|
(if known-immutable?
|
|
varref:static
|
|
varref:per-load-static))]
|
|
|
|
;; Do symbols at most once:
|
|
[(symbol? (zodiac:zread-object ast))
|
|
(let ([sym (zodiac:zread-object ast)])
|
|
(compiler:get-symbol-const! ast sym))]
|
|
|
|
;; Numbers that must be built
|
|
[(number? (zodiac:zread-object ast))
|
|
(let ([n (zodiac:zread-object ast)])
|
|
(if (and (inexact? n) (eqv? 0 (imag-part n))
|
|
(not (member n '(+inf.0 -inf.0 +nan.0 -0.0))))
|
|
(compiler:get-inexact-real-const! n ast)
|
|
(let ([sym (string->symbol (number->string n))])
|
|
(hash-table-get const:number-table
|
|
sym
|
|
(lambda ()
|
|
(let ([num (compiler:add-const!
|
|
(compiler:re-quote ast)
|
|
varref:static)])
|
|
(hash-table-put! const:number-table sym num)
|
|
num))))))]
|
|
|
|
;; big/cyclic constants
|
|
[(big-and-simple/cyclic? (syntax-object->datum (zodiac:zodiac-stx ast)) 20 (make-hash-table))
|
|
(construct-big-constant ast (zodiac:zodiac-stx ast) known-immutable?)]
|
|
|
|
;; lists
|
|
[(stx-list? (zodiac:zodiac-stx ast))
|
|
(construct-vector-constant ast 'list known-immutable?)]
|
|
|
|
;; improper lists
|
|
[(pair? (zodiac:zread-object ast))
|
|
(construct-vector-constant ast 'list* known-immutable?)]
|
|
|
|
[(void? (zodiac:zread-object ast))
|
|
(zodiac:make-special-constant 'void)]
|
|
|
|
;; vectors
|
|
[(vector? (zodiac:zread-object ast))
|
|
(construct-vector-constant ast 'vector known-immutable?)]
|
|
|
|
;; regexp
|
|
[(regexp? (zodiac:zread-object ast))
|
|
(construct-vector-constant ast 'regexp #t)]
|
|
[(byte-regexp? (zodiac:zread-object ast))
|
|
(construct-vector-constant ast 'byte-regexp #t)]
|
|
|
|
;; comes from module paths in analyze:
|
|
[(module-path-index? (zodiac:zread-object ast))
|
|
(let-values ([(path base) (module-path-index-split (zodiac:zread-object ast))])
|
|
(if (or path base)
|
|
(let ([wrap (lambda (v)
|
|
(zodiac:make-zread
|
|
(datum->syntax-object
|
|
#f
|
|
v
|
|
(zodiac:zodiac-stx ast))))])
|
|
(compiler:add-const! (compiler:make-const-constructor
|
|
ast
|
|
'module-path-index-join
|
|
(list (compiler:construct-const-code!
|
|
(wrap path)
|
|
known-immutable?)
|
|
(compiler:construct-const-code!
|
|
(wrap base)
|
|
known-immutable?)))
|
|
(if known-immutable?
|
|
varref:static
|
|
varref:per-load-static)))
|
|
(zodiac:make-special-constant 'self_modidx)))]
|
|
|
|
;; other atomic constants that must be built
|
|
[else
|
|
(when (or (string? (zodiac:zread-object ast))
|
|
(bytes? (zodiac:zread-object ast)))
|
|
(const:intern-string (zodiac:zread-object ast)))
|
|
(compiler:add-const! (compiler:re-quote ast)
|
|
varref:static)])))))
|
|
|