schemify: add constant folding
Like other optimizations that schemify duplicates, constant folding helps support cross-module optimization. Related "no-prompt" declarations for primitives can reduce `call-with-module-prompt`s in schemified output, too, which can interfere with Chez Scheme's optimizer.
This commit is contained in:
parent
831e75d731
commit
ecabcd385a
|
@ -12,7 +12,7 @@
|
|||
|
||||
(define collection 'multi)
|
||||
|
||||
(define version "7.3.0.11")
|
||||
(define version "7.3.0.12")
|
||||
|
||||
(define deps `("racket-lib"
|
||||
["racket" #:version ,version]))
|
||||
|
|
|
@ -3,6 +3,9 @@
|
|||
racket/pretty
|
||||
racket/match
|
||||
racket/file
|
||||
racket/fixnum
|
||||
racket/flonum
|
||||
racket/unsafe/ops
|
||||
racket/extflonum
|
||||
racket/include
|
||||
"../schemify/schemify.rkt"
|
||||
|
@ -113,6 +116,24 @@
|
|||
(include "primitive/internal.ss")
|
||||
knowns))
|
||||
|
||||
(define primitives
|
||||
(let ([ns (make-base-namespace)])
|
||||
(namespace-attach-module (current-namespace) 'racket/fixnum ns)
|
||||
(namespace-require 'racket/fixnum ns)
|
||||
(namespace-attach-module (current-namespace) 'racket/flonum ns)
|
||||
(namespace-require 'racket/flonum ns)
|
||||
(namespace-attach-module (current-namespace) 'racket/unsafe/ops ns)
|
||||
(namespace-require 'racket/unsafe/ops ns)
|
||||
(define primitives (make-hasheq))
|
||||
(for ([s (in-list (namespace-mapped-symbols ns))])
|
||||
(define v (namespace-variable-value s
|
||||
#t
|
||||
(lambda () #f)
|
||||
ns))
|
||||
(when v
|
||||
(hash-set! primitives s v)))
|
||||
primitives))
|
||||
|
||||
;; Convert:
|
||||
(define schemified-body
|
||||
(let ()
|
||||
|
@ -125,7 +146,7 @@
|
|||
(printf "Schemify...\n")
|
||||
(define body
|
||||
(time
|
||||
(schemify-body bodys/constants-lifted prim-knowns #hasheq() #hasheq() for-cify? unsafe-mode? #t)))
|
||||
(schemify-body bodys/constants-lifted prim-knowns primitives #hasheq() #hasheq() for-cify? unsafe-mode? #t)))
|
||||
(printf "Lift...\n")
|
||||
;; Lift functions to avoid closure creation:
|
||||
(define lifted-body
|
||||
|
|
|
@ -528,6 +528,7 @@
|
|||
inline?
|
||||
(not use-prompt?)
|
||||
prim-knowns
|
||||
primitives
|
||||
;; Callback to get a specific linklet for a
|
||||
;; given import:
|
||||
(if get-import
|
||||
|
|
|
@ -1,71 +1,71 @@
|
|||
|
||||
(define-primitive-table flfxnum-table
|
||||
[->fl (known-procedure 2)]
|
||||
[fl* (known-procedure -1)]
|
||||
[fl+ (known-procedure -1)]
|
||||
[fl- (known-procedure -2)]
|
||||
[fl->exact-integer (known-procedure 2)]
|
||||
[fl->fx (known-procedure/has-unsafe 2 'unsafe-fl->fx)]
|
||||
[fl/ (known-procedure -2)]
|
||||
[fl< (known-procedure -2)]
|
||||
[fl<= (known-procedure -2)]
|
||||
[fl= (known-procedure -2)]
|
||||
[fl> (known-procedure -2)]
|
||||
[fl>= (known-procedure -2)]
|
||||
[flabs (known-procedure 2)]
|
||||
[flacos (known-procedure 2)]
|
||||
[flasin (known-procedure 2)]
|
||||
[flatan (known-procedure 2)]
|
||||
[flceiling (known-procedure 2)]
|
||||
[flcos (known-procedure 2)]
|
||||
[flexp (known-procedure 2)]
|
||||
[flexpt (known-procedure 4)]
|
||||
[flfloor (known-procedure 2)]
|
||||
[flimag-part (known-procedure 2)]
|
||||
[fllog (known-procedure 2)]
|
||||
[flmax (known-procedure -2)]
|
||||
[flmin (known-procedure -2)]
|
||||
[flreal-part (known-procedure 2)]
|
||||
[flround (known-procedure 2)]
|
||||
[flsin (known-procedure 2)]
|
||||
[flsqrt (known-procedure 2)]
|
||||
[fltan (known-procedure 2)]
|
||||
[fltruncate (known-procedure 2)]
|
||||
[flvector (known-procedure -1)]
|
||||
[flvector-length (known-procedure 2)]
|
||||
[flvector-ref (known-procedure 4)]
|
||||
[flvector-set! (known-procedure 8)]
|
||||
[flvector? (known-procedure 2)]
|
||||
[fx* (known-procedure -1)]
|
||||
[fx+ (known-procedure -1)]
|
||||
[fx- (known-procedure -2)]
|
||||
[fx->fl (known-procedure/has-unsafe 2 'unsafe-fx->fl)]
|
||||
[fx< (known-procedure -2)]
|
||||
[fx<= (known-procedure -2)]
|
||||
[fx= (known-procedure -2)]
|
||||
[fx> (known-procedure -2)]
|
||||
[fx>= (known-procedure -2)]
|
||||
[fxabs (known-procedure 2)]
|
||||
[fxand (known-procedure -1)]
|
||||
[fxior (known-procedure -1)]
|
||||
[fxlshift (known-procedure 4)]
|
||||
[fxmax (known-procedure -2)]
|
||||
[fxmin (known-procedure -2)]
|
||||
[fxmodulo (known-procedure 4)]
|
||||
[fxnot (known-procedure 2)]
|
||||
[fxquotient (known-procedure 4)]
|
||||
[fxremainder (known-procedure 4)]
|
||||
[fxrshift (known-procedure 4)]
|
||||
[fxvector (known-procedure -1)]
|
||||
[fxvector-length (known-procedure 2)]
|
||||
[fxvector-ref (known-procedure 4)]
|
||||
[fxvector-set! (known-procedure 8)]
|
||||
[fxvector? (known-procedure 2)]
|
||||
[fxxor (known-procedure -1)]
|
||||
[make-flrectangular (known-procedure 4)]
|
||||
[make-flvector (known-procedure 6)]
|
||||
[make-fxvector (known-procedure 6)]
|
||||
[make-shared-flvector (known-procedure 6)]
|
||||
[make-shared-fxvector (known-procedure 6)]
|
||||
[shared-flvector (known-procedure -1)]
|
||||
[shared-fxvector (known-procedure -1)])
|
||||
[->fl (known-procedure/folding 2)]
|
||||
[fl* (known-procedure/folding -1)]
|
||||
[fl+ (known-procedure/folding -1)]
|
||||
[fl- (known-procedure/folding -2)]
|
||||
[fl->exact-integer (known-procedure/folding 2)]
|
||||
[fl->fx (known-procedure/has-unsafe/folding 2 'unsafe-fl->fx)]
|
||||
[fl/ (known-procedure/folding -2)]
|
||||
[fl< (known-procedure/folding -2)]
|
||||
[fl<= (known-procedure/folding -2)]
|
||||
[fl= (known-procedure/folding -2)]
|
||||
[fl> (known-procedure/folding -2)]
|
||||
[fl>= (known-procedure/folding -2)]
|
||||
[flabs (known-procedure/folding 2)]
|
||||
[flacos (known-procedure/folding 2)]
|
||||
[flasin (known-procedure/folding 2)]
|
||||
[flatan (known-procedure/folding 2)]
|
||||
[flceiling (known-procedure/folding 2)]
|
||||
[flcos (known-procedure/folding 2)]
|
||||
[flexp (known-procedure/folding 2)]
|
||||
[flexpt (known-procedure/folding 4)]
|
||||
[flfloor (known-procedure/folding 2)]
|
||||
[flimag-part (known-procedure/folding 2)]
|
||||
[fllog (known-procedure/folding 2)]
|
||||
[flmax (known-procedure/folding -2)]
|
||||
[flmin (known-procedure/folding -2)]
|
||||
[flreal-part (known-procedure/folding 2)]
|
||||
[flround (known-procedure/folding 2)]
|
||||
[flsin (known-procedure/folding 2)]
|
||||
[flsqrt (known-procedure/folding 2)]
|
||||
[fltan (known-procedure/folding 2)]
|
||||
[fltruncate (known-procedure/folding 2)]
|
||||
[flvector (known-procedure/folding -1)]
|
||||
[flvector-length (known-procedure/folding 2)]
|
||||
[flvector-ref (known-procedure/folding 4)]
|
||||
[flvector-set! (known-procedure/folding 8)]
|
||||
[flvector? (known-procedure/pure/folding 2)]
|
||||
[fx* (known-procedure/folding/limited -1 'fixnum)]
|
||||
[fx+ (known-procedure/folding/limited -1 'fixnum)]
|
||||
[fx- (known-procedure/folding/limited -2 'fixnum)]
|
||||
[fx->fl (known-procedure/has-unsafe/folding/limited 2 'unsafe-fx->fl 'fixnum)]
|
||||
[fx< (known-procedure/folding/limited -2 'fixnum)]
|
||||
[fx<= (known-procedure/folding/limited -2 'fixnum)]
|
||||
[fx= (known-procedure/folding/limited -2 'fixnum)]
|
||||
[fx> (known-procedure/folding/limited -2 'fixnum)]
|
||||
[fx>= (known-procedure/folding/limited -2 'fixnum)]
|
||||
[fxabs (known-procedure/folding/limited 2 'fixnum)]
|
||||
[fxand (known-procedure/folding/limited -1 'fixnum)]
|
||||
[fxior (known-procedure/folding/limited -1 'fixnum)]
|
||||
[fxlshift (known-procedure/folding/limited 4 'fixnum)]
|
||||
[fxmax (known-procedure/folding/limited -2 'fixnum)]
|
||||
[fxmin (known-procedure/folding/limited -2 'fixnum)]
|
||||
[fxmodulo (known-procedure/folding/limited 4 'fixnum)]
|
||||
[fxnot (known-procedure/folding/limited 2 'fixnum)]
|
||||
[fxquotient (known-procedure/folding/limited 4 'fixnum)]
|
||||
[fxremainder (known-procedure/folding/limited 4 'fixnum)]
|
||||
[fxrshift (known-procedure/folding/limited 4 'fixnum)]
|
||||
[fxvector (known-procedure/folding/limited -1 'fixnum)]
|
||||
[fxvector-length (known-procedure/folding/limited 2 'fixnum)]
|
||||
[fxvector-ref (known-procedure/folding/limited 4 'fixnum)]
|
||||
[fxvector-set! (known-procedure/folding/limited 8 'fixnum)]
|
||||
[fxvector? (known-procedure/pure/folding 2)]
|
||||
[fxxor (known-procedure/folding/limited -1 'fixnum)]
|
||||
[make-flrectangular (known-procedure/folding 4)]
|
||||
[make-flvector (known-procedure/no-prompt 6)]
|
||||
[make-fxvector (known-procedure/no-prompt 6)]
|
||||
[make-shared-flvector (known-procedure/no-prompt 6)]
|
||||
[make-shared-fxvector (known-procedure/no-prompt 6)]
|
||||
[shared-flvector (known-procedure/no-prompt -1)]
|
||||
[shared-fxvector (known-procedure/no-prompt -1)])
|
||||
|
|
File diff suppressed because it is too large
Load Diff
|
@ -18,12 +18,12 @@
|
|||
[unsafe-cdr (known-procedure/pure 2)]
|
||||
[unsafe-chaperone-procedure (known-procedure -4)]
|
||||
[unsafe-chaperone-vector (known-procedure -4)]
|
||||
[unsafe-char<? (known-procedure/pure -2)]
|
||||
[unsafe-char<=? (known-procedure/pure -2)]
|
||||
[unsafe-char=? (known-procedure/pure -2)]
|
||||
[unsafe-char>? (known-procedure/pure -2)]
|
||||
[unsafe-char>=? (known-procedure/pure -2)]
|
||||
[unsafe-char->integer (known-procedure/pure 2)]
|
||||
[unsafe-char<? (known-procedure/pure/folding-unsafe -2 'char<?)]
|
||||
[unsafe-char<=? (known-procedure/pure/folding-unsafe -2 'char<=?)]
|
||||
[unsafe-char=? (known-procedure/pure/folding-unsafe -2 'char=?)]
|
||||
[unsafe-char>? (known-procedure/pure/folding-unsafe -2 'char>?)]
|
||||
[unsafe-char>=? (known-procedure/pure/folding-unsafe -2 'char>=?)]
|
||||
[unsafe-char->integer (known-procedure/pure/folding-unsafe 2 'char->integer)]
|
||||
[unsafe-cons-list (known-procedure/pure 4)]
|
||||
[unsafe-custodian-register (known-procedure 32)]
|
||||
[unsafe-custodian-unregister (known-procedure 4)]
|
||||
|
@ -52,51 +52,51 @@
|
|||
[unsafe-f80vector-set! (known-procedure 8)]
|
||||
[unsafe-file-descriptor->port (known-procedure 8)]
|
||||
[unsafe-file-descriptor->semaphore (known-procedure 4)]
|
||||
[unsafe-fl* (known-procedure/pure -1)]
|
||||
[unsafe-fl+ (known-procedure/pure -1)]
|
||||
[unsafe-fl- (known-procedure/pure -2)]
|
||||
[unsafe-fl->fx (known-procedure/pure 2)]
|
||||
[unsafe-fl/ (known-procedure/pure -2)]
|
||||
[unsafe-fl< (known-procedure/pure -2)]
|
||||
[unsafe-fl<= (known-procedure/pure -2)]
|
||||
[unsafe-fl= (known-procedure/pure -2)]
|
||||
[unsafe-fl> (known-procedure/pure -2)]
|
||||
[unsafe-fl>= (known-procedure/pure -2)]
|
||||
[unsafe-flabs (known-procedure/pure 2)]
|
||||
[unsafe-flimag-part (known-procedure/pure 2)]
|
||||
[unsafe-flmax (known-procedure/pure 4)]
|
||||
[unsafe-flmin (known-procedure/pure 4)]
|
||||
[unsafe-flrandom (known-procedure/pure 2)]
|
||||
[unsafe-flreal-part (known-procedure/pure 2)]
|
||||
[unsafe-flsqrt (known-procedure/pure 2)]
|
||||
[unsafe-flvector-length (known-procedure/pure 2)]
|
||||
[unsafe-fl* (known-procedure/pure/folding-unsafe -1 'fl*)]
|
||||
[unsafe-fl+ (known-procedure/pure/folding-unsafe -1 'fl+)]
|
||||
[unsafe-fl- (known-procedure/pure/folding-unsafe -2 'fl-)]
|
||||
[unsafe-fl->fx (known-procedure/pure/folding-unsafe 2 'fl->fx)]
|
||||
[unsafe-fl/ (known-procedure/pure/folding-unsafe -2 'fl/)]
|
||||
[unsafe-fl< (known-procedure/pure/folding-unsafe -2 'fl<)]
|
||||
[unsafe-fl<= (known-procedure/pure/folding-unsafe -2 'fl<=)]
|
||||
[unsafe-fl= (known-procedure/pure/folding-unsafe -2 'fl=)]
|
||||
[unsafe-fl> (known-procedure/pure/folding-unsafe -2 'fl>)]
|
||||
[unsafe-fl>= (known-procedure/pure/folding-unsafe -2 'fl>=)]
|
||||
[unsafe-flabs (known-procedure/pure/folding-unsafe 2 'flabs)]
|
||||
[unsafe-flimag-part (known-procedure/pure/folding-unsafe 2 'flimag-part)]
|
||||
[unsafe-flmax (known-procedure/pure/folding-unsafe 4 'flmax)]
|
||||
[unsafe-flmin (known-procedure/pure/folding-unsafe 4 'flmin)]
|
||||
[unsafe-flrandom (known-procedure/pure/folding-unsafe 2 'flrandom)]
|
||||
[unsafe-flreal-part (known-procedure/pure/folding-unsafe 2 'flreal-part)]
|
||||
[unsafe-flsqrt (known-procedure/pure/folding-unsafe 2 'flsqrt)]
|
||||
[unsafe-flvector-length (known-procedure/pure/folding-unsafe 2 'flvector-length)]
|
||||
[unsafe-flvector-ref (known-procedure 4)]
|
||||
[unsafe-flvector-set! (known-procedure 8)]
|
||||
[unsafe-fx* (known-procedure/pure -1)]
|
||||
[unsafe-fx+ (known-procedure/pure -1)]
|
||||
[unsafe-fx- (known-procedure/pure -2)]
|
||||
[unsafe-fx->extfl (known-procedure/pure 2)]
|
||||
[unsafe-fx->fl (known-procedure/pure 2)]
|
||||
[unsafe-fx< (known-procedure/pure -2)]
|
||||
[unsafe-fx<= (known-procedure/pure -2)]
|
||||
[unsafe-fx= (known-procedure/pure -2)]
|
||||
[unsafe-fx> (known-procedure/pure -2)]
|
||||
[unsafe-fx>= (known-procedure/pure -2)]
|
||||
[unsafe-fxabs (known-procedure/pure 2)]
|
||||
[unsafe-fxand (known-procedure/pure -1)]
|
||||
[unsafe-fxior (known-procedure/pure -1)]
|
||||
[unsafe-fxlshift (known-procedure/pure 4)]
|
||||
[unsafe-fxmax (known-procedure/pure -2)]
|
||||
[unsafe-fxmin (known-procedure/pure -2)]
|
||||
[unsafe-fxmodulo (known-procedure/pure 4)]
|
||||
[unsafe-fxnot (known-procedure/pure 2)]
|
||||
[unsafe-fxquotient (known-procedure/pure 4)]
|
||||
[unsafe-fxremainder (known-procedure/pure 4)]
|
||||
[unsafe-fxrshift (known-procedure/pure 4)]
|
||||
[unsafe-fxvector-length (known-procedure/pure 2)]
|
||||
[unsafe-fx* (known-procedure/pure/folding-unsafe -1 'fx*)]
|
||||
[unsafe-fx+ (known-procedure/pure/folding-unsafe -1 'fx+)]
|
||||
[unsafe-fx- (known-procedure/pure/folding-unsafe -2 'fx-)]
|
||||
[unsafe-fx->extfl (known-procedure/pure/folding-unsafe 2 'fx->extfl)]
|
||||
[unsafe-fx->fl (known-procedure/pure/folding-unsafe 2 'fx->fl)]
|
||||
[unsafe-fx< (known-procedure/pure/folding-unsafe -2 'fx<)]
|
||||
[unsafe-fx<= (known-procedure/pure/folding-unsafe -2 'fx<=)]
|
||||
[unsafe-fx= (known-procedure/pure/folding-unsafe -2 'fx=)]
|
||||
[unsafe-fx> (known-procedure/pure/folding-unsafe -2 'fx>)]
|
||||
[unsafe-fx>= (known-procedure/pure/folding-unsafe -2 'fx>=)]
|
||||
[unsafe-fxabs (known-procedure/pure/folding-unsafe 2 'fxabs)]
|
||||
[unsafe-fxand (known-procedure/pure/folding-unsafe -1 'fxand)]
|
||||
[unsafe-fxior (known-procedure/pure/folding-unsafe -1 'fxior)]
|
||||
[unsafe-fxlshift (known-procedure/pure/folding-unsafe 4 'fxlshift)]
|
||||
[unsafe-fxmax (known-procedure/pure/folding-unsafe -2 'fxmax)]
|
||||
[unsafe-fxmin (known-procedure/pure/folding-unsafe -2 'fxmin)]
|
||||
[unsafe-fxmodulo (known-procedure/pure/folding-unsafe 4 'fxmodulo)]
|
||||
[unsafe-fxnot (known-procedure/pure/folding-unsafe 2 'fxnot)]
|
||||
[unsafe-fxquotient (known-procedure/pure/folding-unsafe 4 'fxquotient)]
|
||||
[unsafe-fxremainder (known-procedure/pure/folding-unsafe 4 'fxremainder)]
|
||||
[unsafe-fxrshift (known-procedure/pure/folding-unsafe 4 'fxrshift)]
|
||||
[unsafe-fxvector-length (known-procedure/pure/folding-unsafe 2 'fxvector-length)]
|
||||
[unsafe-fxvector-ref (known-procedure 4)]
|
||||
[unsafe-fxvector-set! (known-procedure 8)]
|
||||
[unsafe-fxxor (known-procedure/pure -1)]
|
||||
[unsafe-fxxor (known-procedure/pure/folding-unsafe -1 'fxxor)]
|
||||
[unsafe-get-place-table (known-procedure 1)]
|
||||
[unsafe-immutable-hash-iterate-first (known-procedure/pure 2)]
|
||||
[unsafe-immutable-hash-iterate-key (known-procedure/pure 4)]
|
||||
|
@ -110,7 +110,7 @@
|
|||
[unsafe-list-ref (known-procedure/pure 4)]
|
||||
[unsafe-list-tail (known-procedure/pure 4)]
|
||||
[unsafe-make-custodian-at-root (known-procedure 1)]
|
||||
[unsafe-make-flrectangular (known-procedure/pure 4)]
|
||||
[unsafe-make-flrectangular (known-procedure/pure/folding-unsafe 4 'make-flrectangular)]
|
||||
[unsafe-make-place-local (known-procedure/pure 2)]
|
||||
[unsafe-make-os-semaphore (known-procedure 1)]
|
||||
[unsafe-make-security-guard-at-root (known-procedure 15)]
|
||||
|
|
|
@ -74,7 +74,7 @@
|
|||
(printf "Schemify...\n")
|
||||
(define body
|
||||
(time
|
||||
(schemify-body bodys/re-uniqued prim-knowns #hasheq() #hasheq()
|
||||
(schemify-body bodys/re-uniqued prim-knowns #hasheq() #hasheq() #hasheq()
|
||||
;; for cify:
|
||||
#t
|
||||
;; unsafe mode:
|
||||
|
|
|
@ -16,7 +16,7 @@
|
|||
#define MZSCHEME_VERSION_X 7
|
||||
#define MZSCHEME_VERSION_Y 3
|
||||
#define MZSCHEME_VERSION_Z 0
|
||||
#define MZSCHEME_VERSION_W 11
|
||||
#define MZSCHEME_VERSION_W 12
|
||||
|
||||
/* A level of indirection makes `#` work as needed: */
|
||||
#define AS_a_STR_HELPER(x) #x
|
||||
|
|
|
@ -12,14 +12,16 @@
|
|||
;; Record top-level functions and structure types, and returns
|
||||
;; (values knowns struct-type-info-or-#f)
|
||||
(define (find-definitions v prim-knowns knowns imports mutated simples unsafe-mode?
|
||||
#:primitives [primitives #hasheq()] ; for `optimize?` mode
|
||||
#:optimize? optimize?)
|
||||
(match v
|
||||
[`(define-values (,id) ,orig-rhs)
|
||||
(define rhs (if optimize?
|
||||
(optimize orig-rhs prim-knowns knowns imports mutated)
|
||||
(optimize orig-rhs prim-knowns primitives knowns imports mutated)
|
||||
orig-rhs))
|
||||
(values
|
||||
(let ([k (infer-known rhs v #t id knowns prim-knowns imports mutated simples unsafe-mode?
|
||||
#:primitives primitives
|
||||
#:optimize-inline? optimize?)])
|
||||
(if k
|
||||
(hash-set knowns (unwrap id) k)
|
||||
|
|
56
racket/src/schemify/fold.rkt
Normal file
56
racket/src/schemify/fold.rkt
Normal file
|
@ -0,0 +1,56 @@
|
|||
#lang racket/base
|
||||
(require racket/fixnum
|
||||
"literal.rkt"
|
||||
"known.rkt")
|
||||
|
||||
(provide try-fold-primitive)
|
||||
|
||||
(define (try-fold-primitive orig-prim-sym orig-k exps prim-knowns primitives)
|
||||
(define prim-sym (if (known-procedure/pure/folding-unsafe? orig-k)
|
||||
(known-procedure/pure/folding-unsafe-safe orig-k)
|
||||
orig-prim-sym))
|
||||
(define k (if (known-procedure/pure/folding-unsafe? orig-k)
|
||||
(hash-ref prim-knowns prim-sym #f)
|
||||
orig-k))
|
||||
(define vals (for/list ([exp (in-list exps)])
|
||||
(unwrap-literal exp)))
|
||||
(define check-result (limit-check k vals))
|
||||
(and check-result
|
||||
(let/ec esc
|
||||
(call-with-exception-handler
|
||||
(lambda (exn)
|
||||
(if (exn:fail? exn)
|
||||
(esc #f)
|
||||
exn))
|
||||
(lambda ()
|
||||
(define result
|
||||
(apply (hash-ref primitives prim-sym (lambda args (error "missing")))
|
||||
vals))
|
||||
(check-result result)
|
||||
(list (wrap-literal result)))))))
|
||||
|
||||
(define (limit-check k vals)
|
||||
(define kind
|
||||
(cond
|
||||
[(known-procedure/folding/limited? k)
|
||||
(known-procedure/folding/limited-kind k)]
|
||||
[(known-procedure/has-unsafe/folding/limited? k)
|
||||
(known-procedure/has-unsafe/folding/limited-kind k)]
|
||||
[else #f]))
|
||||
(case kind
|
||||
[(#f) void]
|
||||
[(expt)
|
||||
(and (not (and (= 2 (length vals))
|
||||
(exact-integer? (car vals))
|
||||
(exact-integer? (cadr vals))
|
||||
((* (integer-length (car vals))
|
||||
(cadr vals))
|
||||
. > . 1000)))
|
||||
void)]
|
||||
[(fixnum) (and (for/and ([v (in-list vals)])
|
||||
(fixnum-for-every-system? v))
|
||||
(lambda (v)
|
||||
(unless (fixnum-for-every-system? v)
|
||||
(error "result is not a fixnum for every system"))))]
|
||||
[else
|
||||
(error 'schemify:limited-ok? "unknown limit kind: ~a" k)]))
|
|
@ -18,6 +18,7 @@
|
|||
;; that the variable will get a value without referencing anything
|
||||
;; too early.
|
||||
(define (infer-known rhs defn rec? id knowns prim-knowns imports mutated simples unsafe-mode?
|
||||
#:primitives [primitives #hasheq()] ; for `optimize-inline?` mode
|
||||
#:optimize-inline? [optimize-inline? #f])
|
||||
(cond
|
||||
[(lambda? rhs)
|
||||
|
@ -27,7 +28,7 @@
|
|||
(or (can-inline? lam)
|
||||
(wrap-property defn 'compiler-hint:cross-module-inline)))
|
||||
(let ([lam (if optimize-inline?
|
||||
(optimize* lam prim-knowns knowns imports mutated unsafe-mode?)
|
||||
(optimize* lam prim-knowns primitives knowns imports mutated unsafe-mode?)
|
||||
lam)])
|
||||
(known-procedure/can-inline arity-mask lam))
|
||||
(known-procedure arity-mask))]
|
||||
|
|
|
@ -6,14 +6,23 @@
|
|||
(provide known-constant known-constant?
|
||||
known-consistent known-consistent?
|
||||
known-copy? known-copy known-copy-id
|
||||
known-literal known-literal? known-literal-expr
|
||||
known-literal known-literal? known-literal-value
|
||||
known-procedure known-procedure? known-procedure-arity-mask
|
||||
known-procedure/no-prompt known-procedure/no-prompt?
|
||||
known-procedure/folding known-procedure/folding?
|
||||
known-procedure/folding/limited known-procedure/folding/limited? known-procedure/folding/limited-kind
|
||||
known-procedure/can-inline known-procedure/can-inline? known-procedure/can-inline-expr
|
||||
known-procedure/can-inline/need-imports known-procedure/can-inline/need-imports?
|
||||
known-procedure/can-inline/need-imports-needed
|
||||
known-procedure/succeeds known-procedure/succeeds?
|
||||
known-procedure/pure known-procedure/pure?
|
||||
known-procedure/pure/folding known-procedure/pure/folding? ; not a subtype of `known-procedure/folding`
|
||||
known-procedure/pure/folding-unsafe known-procedure/pure/folding-unsafe?
|
||||
known-procedure/pure/folding-unsafe-safe
|
||||
known-procedure/has-unsafe known-procedure/has-unsafe? known-procedure/has-unsafe-alternate
|
||||
known-procedure/has-unsafe/folding known-procedure/has-unsafe/folding? ; not a subtype of `known-procedure/folding`
|
||||
known-procedure/has-unsafe/folding/limited known-procedure/has-unsafe/folding/limited?
|
||||
known-procedure/has-unsafe/folding/limited-kind
|
||||
known-struct-type known-struct-type? known-struct-type-type
|
||||
known-struct-type-field-count known-struct-type-pure-constructor?
|
||||
known-constructor known-constructor? known-constructor-type
|
||||
|
@ -41,26 +50,45 @@
|
|||
(struct known-copy (id) #:prefab #:omit-define-syntaxes #:super struct:known-constant)
|
||||
|
||||
;; literal for constant propagation:
|
||||
(struct known-literal (expr) #:prefab #:omit-define-syntaxes #:super struct:known-consistent)
|
||||
(struct known-literal (value) #:prefab #:omit-define-syntaxes #:super struct:known-consistent)
|
||||
|
||||
;; procedure with arity mark; the procedure has to be a procedure from the host
|
||||
;; Scheme's perspective --- not an applicable struct or chaperoned procedure, which
|
||||
;; means that parameters don't count
|
||||
(struct known-procedure (arity-mask) #:prefab #:omit-define-syntaxes #:super struct:known-consistent)
|
||||
|
||||
;; procedure that does not need to run inside a module prompt, which implies that the
|
||||
;; procedure does not call arbitrary other code, not even through an impersonator/chaperone
|
||||
;; interposition procedure
|
||||
(struct known-procedure/no-prompt () #:prefab #:omit-define-syntaxes #:super struct:known-procedure)
|
||||
|
||||
;; procedure that can be inlined, where the `expr` is in pre-schemify form
|
||||
(struct known-procedure/can-inline (expr) #:prefab #:omit-define-syntaxes #:super struct:known-procedure)
|
||||
(struct known-procedure/can-inline/need-imports (needed) ; (list (cons <sym> (cons <sym> <#f-or-index>)) ...)
|
||||
#:prefab #:omit-define-syntaxes #:super struct:known-procedure/can-inline)
|
||||
|
||||
;; procedure that can be applied at compile time to literals and returns a single value
|
||||
(struct known-procedure/folding () #:prefab #:omit-define-syntaxes #:super struct:known-procedure/no-prompt)
|
||||
|
||||
;; procedure that's folding, but with some constraint described by `kind` (e.g.,
|
||||
;; `'expt` to mean "apply only to small numbers")
|
||||
(struct known-procedure/folding/limited (kind) #:prefab #:omit-define-syntaxes #:super struct:known-procedure/folding)
|
||||
|
||||
;; procedure that never raises an exception or otherwise captures/escapes the calling context
|
||||
(struct known-procedure/succeeds () #:prefab #:omit-define-syntaxes #:super struct:known-procedure)
|
||||
(struct known-procedure/succeeds () #:prefab #:omit-define-syntaxes #:super struct:known-procedure/no-prompt)
|
||||
|
||||
;; procedure that accepts any arguments and is functional so that it can be reordered
|
||||
(struct known-procedure/pure () #:prefab #:omit-define-syntaxes #:super struct:known-procedure/succeeds)
|
||||
|
||||
;; procedure with an unsafe variant, especially ones that won't get substituted
|
||||
;; pure and folding:
|
||||
(struct known-procedure/pure/folding () #:prefab #:omit-define-syntaxes #:super struct:known-procedure/pure)
|
||||
(struct known-procedure/pure/folding-unsafe (safe) #:prefab #:omit-define-syntaxes #:super struct:known-procedure/pure/folding)
|
||||
|
||||
;; procedure (no-prompt) with an unsafe variant, especially ones that won't get substituted
|
||||
;; simply by compiling in unsafe mode
|
||||
(struct known-procedure/has-unsafe (alternate) #:prefab #:omit-define-syntaxes #:super struct:known-procedure)
|
||||
(struct known-procedure/has-unsafe (alternate) #:prefab #:omit-define-syntaxes #:super struct:known-procedure/no-prompt)
|
||||
(struct known-procedure/has-unsafe/folding () #:prefab #:omit-define-syntaxes #:super struct:known-procedure/has-unsafe)
|
||||
(struct known-procedure/has-unsafe/folding/limited (kind) #:prefab #:omit-define-syntaxes #:super struct:known-procedure/has-unsafe/folding)
|
||||
|
||||
(struct known-struct-type (type field-count pure-constructor?) #:prefab #:omit-define-syntaxes #:super struct:known-consistent)
|
||||
|
||||
|
|
|
@ -2,21 +2,46 @@
|
|||
(require "wrap.rkt")
|
||||
|
||||
(provide literal?
|
||||
unwrap-literal)
|
||||
unwrap-literal
|
||||
wrap-literal)
|
||||
|
||||
(define (literal? v)
|
||||
(define u (unwrap v))
|
||||
(or (number? u)
|
||||
(boolean? u)
|
||||
(eq? u 'eof)
|
||||
(and (pair? u)
|
||||
(eq? (unwrap (car u)) 'quote)
|
||||
(let ([u (unwrap (wrap-car (cdr u)))])
|
||||
(or (symbol? u)
|
||||
(null? u))))))
|
||||
(let ([a (unwrap (car u))])
|
||||
(cond
|
||||
[(eq? a 'quote)
|
||||
(let ([u (unwrap (cadr u))])
|
||||
(or (symbol? u)
|
||||
(null? u)
|
||||
(char? u)
|
||||
(void? u)))]
|
||||
[(and (eq? a 'void)
|
||||
(null? (cdr u)))
|
||||
#t]
|
||||
[else #f])))))
|
||||
|
||||
;; Unwrap a literal so that it can be serialized
|
||||
;; or constant-folded
|
||||
(define (unwrap-literal v)
|
||||
(define u (unwrap v))
|
||||
(if (pair? u)
|
||||
`',(unwrap (wrap-car (cdr u)))
|
||||
u))
|
||||
(cond
|
||||
[(pair? u)
|
||||
(let ([a (unwrap (car u))])
|
||||
(cond
|
||||
[(eq? a 'quote) (unwrap (cadr u))]
|
||||
[(eq? a 'void) (void)]))]
|
||||
[(eq? u 'eof) eof]
|
||||
[else u]))
|
||||
|
||||
(define (wrap-literal x)
|
||||
(cond
|
||||
[(or (string? x) (bytes? x) (boolean? x) (number? x))
|
||||
x]
|
||||
[(void? x) '(void)]
|
||||
[(eof-object? x) 'eof]
|
||||
[else
|
||||
`(quote ,x)]))
|
||||
|
|
|
@ -5,7 +5,8 @@
|
|||
"known.rkt"
|
||||
"find-known.rkt"
|
||||
"mutated-state.rkt"
|
||||
"literal.rkt")
|
||||
"literal.rkt"
|
||||
"fold.rkt")
|
||||
|
||||
(provide optimize
|
||||
optimize*)
|
||||
|
@ -14,7 +15,7 @@
|
|||
;; on each schemified form, which means that subexpressions of the
|
||||
;; immediate expression have already been optimized.
|
||||
|
||||
(define (optimize v prim-knowns knowns imports mutated)
|
||||
(define (optimize v prim-knowns primitives knowns imports mutated)
|
||||
(match v
|
||||
[`(if ,t ,e1 ,e2)
|
||||
(if (literal? t)
|
||||
|
@ -45,6 +46,19 @@
|
|||
'#t
|
||||
v)]
|
||||
[else v])]
|
||||
[`(,rator . ,rands)
|
||||
(define u-rator (unwrap rator))
|
||||
(define k (and (symbol? u-rator) (hash-ref prim-knowns u-rator #f)))
|
||||
(cond
|
||||
[(and k
|
||||
(or (known-procedure/folding? k)
|
||||
(known-procedure/pure/folding? k)
|
||||
(known-procedure/has-unsafe/folding? k))
|
||||
(for/and ([rand (in-list rands)])
|
||||
(literal? rand))
|
||||
(try-fold-primitive u-rator k rands prim-knowns primitives))
|
||||
=> (lambda (l) (car l))]
|
||||
[else v])]
|
||||
[`,_
|
||||
(define u (unwrap v))
|
||||
(cond
|
||||
|
@ -53,7 +67,7 @@
|
|||
(cond
|
||||
[(and (known-literal? k)
|
||||
(simple-mutated-state? (hash-ref mutated u #f)))
|
||||
(known-literal-expr k)]
|
||||
(wrap-literal (known-literal-value k))]
|
||||
;; Note: we can't do `known-copy?` here, because a copy of
|
||||
;; an imported or exported name will need to be schemified
|
||||
;; to a different name
|
||||
|
@ -67,7 +81,7 @@
|
|||
;; function that can be inlined (where converting away
|
||||
;; `variable-reference-from-unsafe?` is particularly important)
|
||||
|
||||
(define (optimize* v prim-knowns knowns imports mutated unsafe-mode?)
|
||||
(define (optimize* v prim-knowns primitives knowns imports mutated unsafe-mode?)
|
||||
(define (optimize* v)
|
||||
(define new-v
|
||||
(reannotate
|
||||
|
@ -98,7 +112,7 @@
|
|||
[`(,rator ,exps ...)
|
||||
`(,(optimize* rator) ,@(optimize*-body exps))]
|
||||
[`,_ v])))
|
||||
(optimize new-v prim-knowns knowns imports mutated))
|
||||
(optimize new-v prim-knowns primitives knowns imports mutated))
|
||||
|
||||
(define (optimize*-body body)
|
||||
(for/list ([v (in-wrap-list body)])
|
||||
|
|
|
@ -7,19 +7,37 @@
|
|||
"schemify.rkt"
|
||||
"known.rkt")
|
||||
|
||||
(define prim-knowns
|
||||
(define-values (prim-knowns primitives)
|
||||
;; Register primitives
|
||||
(let ([ns (make-base-namespace)])
|
||||
(parameterize ([current-namespace ns])
|
||||
(namespace-require 'racket/unsafe/ops)
|
||||
(namespace-require 'racket/flonum)
|
||||
(namespace-require 'racket/fixnum))
|
||||
(for/hasheq ([s (in-list (namespace-mapped-symbols ns))]
|
||||
#:when (with-handlers ([exn:fail? (lambda (x) #f)])
|
||||
(procedure? (eval s ns))))
|
||||
(values s (known-procedure (procedure-arity-mask (eval s ns)))))))
|
||||
(define primitives
|
||||
(for/hasheq ([s (in-list (namespace-mapped-symbols ns))]
|
||||
#:when (with-handlers ([exn:fail? (lambda (x) #f)])
|
||||
(procedure? (eval s ns))))
|
||||
(values s (eval s ns))))
|
||||
(values
|
||||
(for/hasheq ([(s v) (in-hash primitives)])
|
||||
(define a (procedure-arity-mask v))
|
||||
(values s (case s
|
||||
[(+ - * /)
|
||||
(known-procedure/folding a)]
|
||||
[(fx+ fxlshift)
|
||||
(known-procedure/folding/limited a 'fixnum)]
|
||||
[(expt arithmetic-shift)
|
||||
(known-procedure/folding/limited a 'expt)]
|
||||
[(unsafe-fx+)
|
||||
(known-procedure/pure/folding-unsafe a 'fx+)]
|
||||
[else
|
||||
(known-procedure a)])))
|
||||
primitives)))
|
||||
|
||||
(define (wrap p)
|
||||
p
|
||||
#;
|
||||
(cond
|
||||
[(and (pair? p)
|
||||
(eq? (car p) 'define-values))
|
||||
|
@ -42,7 +60,7 @@
|
|||
(define-values (schemified importss exports import-keys imports-abis exports-info)
|
||||
(schemify-linklet `(linklet
|
||||
()
|
||||
(x y [z ext-z])
|
||||
(x y [z ext-z] w)
|
||||
.
|
||||
,(map
|
||||
wrap
|
||||
|
@ -51,9 +69,15 @@
|
|||
(define-values (y) (make-s (lambda () x) 5))
|
||||
(define-values (x) (lambda () y))
|
||||
(x)
|
||||
(define-values (w) (case-lambda [() (+ 1 7)] [(a) x]))
|
||||
(letrec-values ([(loop) (lambda () (loop))]) (loop))
|
||||
(let-values ([(a) 1] [(b) 2]) (list a b))
|
||||
(let-values ([(a b) (values 1 2)]) (list a b))
|
||||
(let-values ([(a b) (values 1 (+ 2 3))])
|
||||
(list a
|
||||
b
|
||||
(arithmetic-shift 3 1000)
|
||||
(fx+ 4 5) (fx+ 4 (expt 2 40)) (fx* (fxlshift 1 20) (fxlshift 1 20))
|
||||
(unsafe-fx+ 4 5) (unsafe-fx+ 4 (expt 2 40))))
|
||||
(define-values (done) (z)))))
|
||||
#;
|
||||
(call-with-input-file "regexp.rktl" read)
|
||||
|
@ -66,6 +90,7 @@
|
|||
#t ; allow-inline?
|
||||
#f ; no-prompt?
|
||||
prim-knowns
|
||||
primitives
|
||||
#f
|
||||
#f))
|
||||
|
||||
|
|
|
@ -20,7 +20,8 @@
|
|||
"inline.rkt"
|
||||
"letrec.rkt"
|
||||
"infer-name.rkt"
|
||||
"ptr-ref-set.rkt")
|
||||
"ptr-ref-set.rkt"
|
||||
"literal.rkt")
|
||||
|
||||
(provide schemify-linklet
|
||||
schemify-body)
|
||||
|
@ -74,7 +75,7 @@
|
|||
;; means that a variable (which boxes a value) is expected.
|
||||
(define (schemify-linklet lk serializable? datum-intern? for-jitify? allow-set!-undefined?
|
||||
unsafe-mode? enforce-constant? allow-inline? no-prompt?
|
||||
prim-knowns get-import-knowns import-keys)
|
||||
prim-knowns primitives get-import-knowns import-keys)
|
||||
(define (im-int-id id) (unwrap (if (pair? id) (cadr id) id)))
|
||||
(define (im-ext-id id) (unwrap (if (pair? id) (car id) id)))
|
||||
(define (ex-int-id id) (unwrap (if (pair? id) (car id) id)))
|
||||
|
@ -131,7 +132,7 @@
|
|||
(define src-syms (get-definition-source-syms bodys))
|
||||
;; Schemify the body, collecting information about defined names:
|
||||
(define-values (new-body defn-info mutated)
|
||||
(schemify-body* bodys/constants-lifted prim-knowns imports exports
|
||||
(schemify-body* bodys/constants-lifted prim-knowns primitives imports exports
|
||||
for-jitify? allow-set!-undefined? add-import! #f
|
||||
unsafe-mode? enforce-constant? allow-inline? no-prompt?))
|
||||
(define all-grps (append grps (reverse new-grps)))
|
||||
|
@ -181,14 +182,14 @@
|
|||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define (schemify-body l prim-knowns imports exports for-cify? unsafe-mode? no-prompt?)
|
||||
(define (schemify-body l prim-knowns primitives imports exports for-cify? unsafe-mode? no-prompt?)
|
||||
(define-values (new-body defn-info mutated)
|
||||
(schemify-body* l prim-knowns imports exports
|
||||
(schemify-body* l prim-knowns primitives imports exports
|
||||
#f #f (lambda (im ext-id index) #f)
|
||||
for-cify? unsafe-mode? #t #t no-prompt?))
|
||||
new-body)
|
||||
|
||||
(define (schemify-body* l prim-knowns imports exports
|
||||
(define (schemify-body* l prim-knowns primitives imports exports
|
||||
for-jitify? allow-set!-undefined? add-import!
|
||||
for-cify? unsafe-mode? enforce-constant? allow-inline? no-prompt?)
|
||||
;; Keep simple checking efficient by caching results
|
||||
|
@ -202,6 +203,7 @@
|
|||
(for/fold ([knowns (hasheq)]) ([form (in-list l)])
|
||||
(define-values (new-knowns info)
|
||||
(find-definitions form prim-knowns knowns imports mutated simples unsafe-mode?
|
||||
#:primitives primitives
|
||||
#:optimize? #t))
|
||||
new-knowns))
|
||||
;; For non-exported definitions, we may need to create some variables
|
||||
|
@ -241,7 +243,7 @@
|
|||
[else
|
||||
(define form (car l))
|
||||
(define schemified (schemify form
|
||||
prim-knowns knowns mutated imports exports simples
|
||||
prim-knowns primitives knowns mutated imports exports simples
|
||||
allow-set!-undefined?
|
||||
add-import!
|
||||
for-cify? for-jitify?
|
||||
|
@ -404,7 +406,7 @@
|
|||
;; Non-simple `mutated` state overrides bindings in `knowns`; a
|
||||
;; a 'too-early state in `mutated` for a `letrec`-bound variable can be
|
||||
;; effectively canceled with a mapping in `knowns`.
|
||||
(define (schemify v prim-knowns knowns mutated imports exports simples allow-set!-undefined? add-import!
|
||||
(define (schemify v prim-knowns primitives knowns mutated imports exports simples allow-set!-undefined? add-import!
|
||||
for-cify? for-jitify? unsafe-mode? allow-inline? no-prompt?)
|
||||
(let schemify/knowns ([knowns knowns] [inline-fuel init-inline-fuel] [v v])
|
||||
(define (schemify v)
|
||||
|
@ -772,7 +774,7 @@
|
|||
;; We'd normally leave this to `optimize`, but
|
||||
;; need to handle it here before generating a
|
||||
;; reference to the renamed identifier
|
||||
(known-literal-expr k)]
|
||||
(wrap-literal (known-literal-value k))]
|
||||
[(and (known-copy? k)
|
||||
(hash-ref prim-knowns (known-copy-id k) #f))
|
||||
;; Directly reference primitive
|
||||
|
@ -796,7 +798,7 @@
|
|||
;; a mapping that says the variable is ready by now
|
||||
`(check-not-unsafe-undefined ,v ',(too-early-mutated-state-name state u-v))]
|
||||
[else v])]))])))
|
||||
(optimize s-v prim-knowns knowns imports mutated))
|
||||
(optimize s-v prim-knowns primitives knowns imports mutated))
|
||||
|
||||
(define (schemify-body l)
|
||||
(for/list ([e (in-list l)])
|
||||
|
|
|
@ -52,6 +52,9 @@
|
|||
(cached
|
||||
(for/and ([e (in-list es)])
|
||||
(simple? e)))]
|
||||
[`(set! ,_ ,e)
|
||||
#:guard (not pure?)
|
||||
(simple? e)]
|
||||
[`(values ,es ...)
|
||||
#:guard (not pure?)
|
||||
(cached
|
||||
|
@ -65,7 +68,7 @@
|
|||
(hash-ref prim-knowns proc #f))])
|
||||
(and (if pure?
|
||||
(known-procedure/pure? v)
|
||||
(known-procedure/succeeds? v))
|
||||
(known-procedure/no-prompt? v))
|
||||
(bitwise-bit-set? (known-procedure-arity-mask v) (length args))))
|
||||
(simple-mutated-state? (hash-ref mutated proc #f))
|
||||
(for/and ([arg (in-list args)])
|
||||
|
|
Loading…
Reference in New Issue
Block a user