suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

schemify: add constant folding

Browse Source 
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:
Matthew Flatt 2019-07-01 10:12:27 -06:00
parent 831e75d731
commit ecabcd385a
17 changed files with 864 additions and 686 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -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]))

23
racket/src/cs/convert.rkt
View File

@ -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

1
racket/src/cs/linklet.sls
View File

@ -528,6 +528,7 @@
inline?
(not use-prompt?)
prim-knowns
primitives
;; Callback to get a specific linklet for a
;; given import:
(if get-import

138
racket/src/cs/primitive/flfxnum.ss
View File

@ -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)])

1054
racket/src/cs/primitive/kernel.ss
View File

File diff suppressed because it is too large Load Diff

96
racket/src/cs/primitive/unsafe.ss
View File

@ -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)]

2
racket/src/racket/src/cify-startup.rkt
View File

@ -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:

2
racket/src/racket/src/schvers.h
View File

@ -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

4
racket/src/schemify/find-definition.rkt
View File

@ -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
View 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)]))

3
racket/src/schemify/infer-known.rkt
View File

@ -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))]

38
racket/src/schemify/known.rkt
View File

@ -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)

41
racket/src/schemify/literal.rkt
View File

@ -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)]))

24
racket/src/schemify/optimize.rkt
View File

@ -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)])

39
racket/src/schemify/schemify-demo.rkt
View File

@ -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))

22
racket/src/schemify/schemify.rkt
View File

@ -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)])

5
racket/src/schemify/simple.rkt
View File

@ -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)])