suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
6ff9e9ecd5
racket/s/cpletrec.ss
dybvig f7c414bda3 Various updates, mostly to the compiler, including a new lambda 
commonizatio pass and support for specifying default record
equal and hash procedures:

- more staid and consistent Mf-cross main target
    Mf-cross
- cpletrec now replaces the incoming prelexes with new ones so
  that it doesn't have to alter the flags on the incoming ones, since
  the same expander output is passed through the compiler twice while
  compiling a file with macro definitions or libraries.  we were
  getting away without this just by luck.
    cpletrec.ss
- pure? and ivory? now return #t for a primref only if the prim is
  declared to be a proc, since some non-proc prims are mutable, e.g.,
  $active-threads and $collect-request-pending.
    cp0.ss
- $error-handling-mode? and $eol-style? are now properly declared to
  be procs rather than system state variables.
    primdata.ss
- the new pass $check-prelex-flags verifies that prelex referenced,
  multiply-referenced, and assigned flags are set when they
  should be.  (it doesn't, however, complain if a flag is set
  when it need not be.)  when the new system parameter
  $enable-check-prelex-flags is set, $check-prelex-flags is
  called after each major pass that produces Lsrc forms to verify
  that the flags are set correctly in the output of the pass.
  this parameter is unset by default but set when running the
  mats.
    cprep.ss, back.ss, compile.ss, primdata.ss,
    mats/Mf-base
- removed the unnecessary set of prelex referenced flag from the
  build-ref routines when we've just established that it is set.
    syntax.ss, compile.ss
- equivalent-expansion? now prints differences to the current output
  port to aid in debugging.
    mat.ss
- the nanopass that patches calls to library globals into calls to
  their local counterparts during whole-program optimization now
  creates new prelexes and sets the prelex referenced, multiply
  referenced, and assigned flags on the new prelexes rather than
  destructively setting flags on the incoming prelexes.  The
  only known problems this fixes are (1) the multiply referenced
  flag was not previously being set for cross-library calls when
  it should have been, resulting in overly aggressive inlining
  of library exports during whole-program optimization, and (2)
  the referenced flag could sometimes be set for library exports
  that aren't actually used in the final program, which could
  prevent some unreachable code from being eliminated.
    compile.ss
- added support for specifying default record-equal and
  record-hash procedures.
    primdata.ss, cmacros.ss, cpnanopass.ss, prims.ss, newhash.ss,
    gc.c,
    record.ms
- added missing call to relocate for subset-mode tc field, which
  wasn't burning us because the only valid non-false value, the
  symbol system, is in the static generation after the initial heap
  compaction.
    gc.c
- added a lambda-commonization pass that runs after the other
  source optimizations, particularly inlining, and a new parameter
  that controls how hard it works.  the value of commonization-level
  ranges from 0 through 9, with 0 disabling commonization and 9
  maximizing it.  The default value is 0 (disabled).  At present,
  for non-zero level n, the commonizer attempts to commonize
  lambda expressions consisting of 2^(10-n) or more nodes.
  commonization of one or more lambda expressions requires that
  they have identical structure down to the leaf nodes for quote
  expressions, references to unassigned variables, and primitives.
  So that various downstream optimizations aren't disabled, there
  are some additional restrictions, the most important of which
  being that call-position expressions must be identical.  The
  commonizer works by abstracting the code into a helper that
  takes the values of the differing leaf nodes as arguments.
  the name of the helper is formed by concatenating the names of
  the original procedures, separated by '&', and this is the name
  that will show up in a stack trace.  The source location will
  be that of one of the original procedures.  Profiling inhibits
  commonization, because commonization requires profile source
  locations to be identical.
    cpcommonize.ss (new), compile.ss, interpret.ss, cprep.ss,
    primdata.ss, s/Mf-base,
    mats/Mf-base
- cpletrec now always produces a letrec rather than a let for
  single immutable lambda bindings, even when not recursive, for
  consistent expand/optimize output whether the commonizer is
  run or not.
    cpletrec.ss,
    record.ms
- trans-make-ftype-pointer no longer generates a call to
  $verify-ftype-address if the address expression is a call to
  ftype-pointer-address.
    ftype.ss

original commit: b6a3dcc814b64faacc9310fec4a4531fb3f18dcd
2018-01-29 09:20:07 -05:00

394 lines
18 KiB
Scheme
Raw Blame History

"cpletrec.ss"
;;; cpletrec.ss
;;; Copyright 1984-2017 Cisco Systems, Inc.
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;; http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.
#|
Notes:
- cpletrec does not consider a record-ref form or call to a restricted
primitive, like car, to be pure even at optimize-level 3 because it's
possible it will be moved ahead of an explicit test within a sequence
of letrec* bindings.
|#
#|
Handling letrec and letrec*
- call cpletrec on each rhs recursively to determine the new rhs,
whether it's pure, and which of the lhs variables are free in it
- call cpletrec on the body
- build a graph. For letrec, create a link from b1 to b2 iff b2 is free
in b1. for letrec*, also create a link from b1 to b2 if neither is
pure and b1 originally appeared before b2.
- determine the strongly connected components of the graph, partially
sorted so that SCC1 comes before SCC2 if there exists a binding b2
in SCC2 that has a link to a binding b1 in SCC1.
- process each SCC as a separate set of letrec/letrec* bindings:
- for letrec*, sort the bindings of the SCC by their original relative
positions. for letrec, any order will do.
- if SCC contains a single binding b where LHS(b) is not assigned
and RHS(b) is a lambda expression, bind using pure letrec,
- otherwise, if SCC contains a single binding b where LHS(b) is
not free in RHS(b), bind using let
- otherwise, partition into lambda bindings lb ... and complex
bindings cb ... where a binding b is lambda iff LHS(b) is not
assigned and RHS(b) is a lambda expression. Generate:
(let ([LHS(cb) (void)] ...)
(letrec ([LHS(lb) RHS(cb)] ...)
(set! LHS(cb) RHS(cb)) ...
body))
- assimilate nested pure letrec forms
|#
(define $cpletrec
(let ()
(import (nanopass))
(include "base-lang.ss")
(define rtd-flds (csv7:record-field-accessor #!base-rtd 'flds))
(define-pass lift-profile-forms : Lsrc (ir) -> Lsrc ()
(definitions
(with-output-language (Lsrc Expr)
(define lift-profile-forms
; pull out profile forms from simple subforms so the profile
; forms won't interfere with downstream optimizations
(lambda (e* k)
(define extract-profile
(lambda (e profile*)
(define profile?
(lambda (e)
(nanopass-case (Lsrc Expr) e
[(profile ,src) #t]
[(seq ,e1 ,e2) (and (profile? e1) (profile? e2))]
[else #f])))
(define simple?
(lambda (e)
(nanopass-case (Lsrc Expr) e
[(quote ,d) #t]
[(ref ,maybe-src ,x) #t]
[,pr #t]
[(call ,preinfo ,pr ,e*) (eq? (primref-name pr) '$top-level-value)]
[(case-lambda ,preinfo ,cl* ...) #t]
[else #f])))
(nanopass-case (Lsrc Expr) e
[(seq ,e1 ,e2)
(guard (and (profile? e1) (simple? e2)))
(values e2 (cons e1 profile*))]
[else (values e profile*)])))
(let f ([e* e*] [re* '()] [profile* '()])
(if (null? e*)
(fold-left (lambda (e profile) `(seq ,profile ,e))
(k (reverse re*))
profile*)
(let-values ([(e profile*) (extract-profile (car e*) profile*)])
(f (cdr e*) (cons e re*) profile*))))))))
(Expr : Expr (ir) -> Expr ()
[(call ,preinfo ,[e] ,[e*] ...)
(lift-profile-forms (cons e e*)
(lambda (e*)
`(call ,preinfo ,(car e*) ,(cdr e*) ...)))]
[(letrec ([,x* ,[e*]] ...) ,[body])
(lift-profile-forms e*
(lambda (e*)
`(letrec ([,x* ,e*] ...) ,body)))]
[(letrec* ([,x* ,[e*]] ...) ,[body])
(lift-profile-forms e*
(lambda (e*)
`(letrec* ([,x* ,e*] ...) ,body)))]))
(define-pass cpletrec : Lsrc (ir) -> Lsrc ()
(definitions
(define with-initialized-ids
(lambda (old-id* proc)
(let ([new-id* (map (lambda (old-id)
(let ([new-id (make-prelex
(prelex-name old-id)
(let ([flags (prelex-flags old-id)])
(fxlogor
(fxlogand flags (constant prelex-sticky-mask))
(fxsll (fxlogand flags (constant prelex-is-mask))
(constant prelex-was-flags-offset))))
(prelex-source old-id)
#f)])
(prelex-operand-set! old-id new-id)
new-id))
old-id*)])
(let-values ([v* (proc new-id*)])
(for-each (lambda (old-id) (prelex-operand-set! old-id #f)) old-id*)
(apply values v*)))))
(define (Expr* e*)
(if (null? e*)
(values '() #t)
(let-values ([(e e-pure?) (Expr (car e*))]
[(e* e*-pure?) (Expr* (cdr e*))])
(values (cons e e*) (and e-pure? e*-pure?)))))
(with-output-language (Lsrc Expr)
(define build-seq
(lambda (e* body)
(fold-right (lambda (e body) `(seq ,e ,body)) body e*)))
(define build-let
(lambda (call-preinfo lambda-preinfo lhs* rhs* body)
(if (null? lhs*)
body
(let ([interface (length lhs*)])
`(call ,call-preinfo
(case-lambda ,lambda-preinfo
(clause (,lhs* ...) ,interface ,body))
,rhs* ...)))))
(module (cpletrec-letrec)
(define-record-type binding
(fields (immutable lhs) (immutable pos) (mutable rhs) (mutable pure?) (mutable recursive?))
(nongenerative)
(protocol
(lambda (new)
(lambda (lhs pos)
(new lhs pos #f #f #f)))))
(define-record-type node ; isolate stuff needed for compute-sccs!
(parent binding)
(fields (mutable link*) (mutable root) (mutable done))
(nongenerative)
(sealed #t)
(protocol
(lambda (make-new)
(lambda (lhs pos)
((make-new lhs pos) '() #f #f)))))
(define (lambda? x)
(nanopass-case (Lsrc Expr) x
[(case-lambda ,preinfo ,cl* ...) #t]
[else #f]))
(define (cpletrec-bindings *? lhs* rhs*)
(let ([all-b* (map make-node lhs* (enumerate lhs*))])
(let loop ([b* all-b*] [rhs* rhs*] [last-nonpure #f])
(unless (null? b*)
(let ([b (car b*)] [rhs (car rhs*)])
(for-each (lambda (lhs) (set-prelex-seen! lhs #f)) lhs*)
(let-values ([(rhs pure?) (Expr rhs)])
(binding-rhs-set! b rhs)
(binding-pure?-set! b pure?)
(binding-recursive?-set! b (prelex-seen (binding-lhs b)))
(let ([free* (filter (lambda (b) (prelex-seen (binding-lhs b))) all-b*)])
(if (or pure? (not *?))
(begin
(node-link*-set! b free*)
(loop (cdr b*) (cdr rhs*) last-nonpure))
(begin
(node-link*-set! b
(if (and last-nonpure (not (memq last-nonpure free*)))
(cons last-nonpure free*)
free*))
(loop (cdr b*) (cdr rhs*) b))))))))
all-b*))
(define (compute-sccs v*) ; Tarjan's algorithm
(define scc* '())
(define (compute-sccs v)
(define index 0)
(define stack '())
(define (tarjan v)
(let ([v-index index])
(node-root-set! v v-index)
(set! stack (cons v stack))
(set! index (fx+ index 1))
(for-each
(lambda (v^)
(unless (node-done v^)
(unless (node-root v^) (tarjan v^))
(node-root-set! v (fxmin (node-root v) (node-root v^)))))
(node-link* v))
(when (fx= (node-root v) v-index)
(set! scc*
(cons
(let f ([ls stack])
(let ([v^ (car ls)])
(node-done-set! v^ #t)
(cons v^ (if (eq? v^ v)
(begin (set! stack (cdr ls)) '())
(f (cdr ls))))))
scc*)))))
(tarjan v))
(for-each (lambda (v) (unless (node-done v) (compute-sccs v))) v*)
(reverse scc*))
(define (grisly-letrec lb* cb* body)
(let ([rclhs* (fold-right (lambda (b lhs*)
(let ([lhs (binding-lhs b)])
(if (prelex-referenced/assigned lhs)
(cons lhs lhs*)
lhs*)))
'() cb*)])
(build-let (make-preinfo) (make-preinfo-lambda) rclhs* (map (lambda (x) `(quote ,(void))) rclhs*)
(build-letrec (map binding-lhs lb*) (map binding-rhs lb*)
(fold-right (lambda (b body)
(let ([lhs (binding-lhs b)] [rhs (binding-rhs b)])
`(seq
,(if (prelex-referenced lhs)
(begin
(set-prelex-assigned! lhs #t)
`(set! #f ,lhs ,rhs))
rhs)
,body)))
body cb*)))))
(define build-letrec
(lambda (lhs* rhs* body)
(if (null? lhs*)
; dropping source here; could attach to body or add source record
body
(nanopass-case (Lsrc Expr) body
; assimilate nested letrecs
[(letrec ([,x* ,e*] ...) ,body)
`(letrec ([,(append lhs* x*) ,(append rhs* e*)] ...) ,body)]
[else `(letrec ([,lhs* ,rhs*] ...) ,body)]))))
(define (expand-letrec b* body)
(if (null? (cdr b*))
(let* ([b (car b*)] [lhs (binding-lhs b)] [rhs (binding-rhs b)])
(cond
[(and (not (prelex-referenced/assigned lhs)) (binding-pure? b)) body]
[(and (not (prelex-assigned lhs)) (lambda? rhs))
(build-letrec (list lhs) (list rhs) body)]
[(not (memq b (node-link* b)))
(build-let (make-preinfo) (make-preinfo-lambda) (list lhs) (list rhs) body)]
[else (grisly-letrec '() b* body)]))
(let-values ([(lb* cb*) (partition
(lambda (b)
(and (not (prelex-assigned (binding-lhs b)))
(lambda? (binding-rhs b))))
b*)])
(grisly-letrec lb* cb* body))))
(define (cpletrec-letrec *? lhs* rhs* body)
(let ([b* (cpletrec-bindings *? lhs* rhs*)])
(let-values ([(body body-pure?) (Expr body)])
(values
(let f ([scc* (compute-sccs b*)])
(if (null? scc*)
body
(expand-letrec
(if *?
(sort
(lambda (b1 b2) (fx< (binding-pos b1) (binding-pos b2)))
(car scc*))
(car scc*))
(f (cdr scc*)))))
(and body-pure? (andmap binding-pure? b*)))))))))
(Expr : Expr (ir) -> Expr (#t)
[(ref ,maybe-src ,x)
(let ([x (prelex-operand x)])
(safe-assert (prelex? x))
(safe-assert (prelex-was-referenced x))
(when (prelex-referenced x)
(safe-assert (prelex-was-multiply-referenced x))
(set-prelex-multiply-referenced! x #t))
(set-prelex-seen/referenced! x #t)
(values `(ref ,maybe-src ,x) (not (prelex-was-assigned x))))]
[(quote ,d) (values ir #t)]
[(call ,preinfo0 (case-lambda ,preinfo1 (clause (,x* ...) ,interface ,body)) ,e* ...)
(guard (fx= (length e*) interface))
(with-initialized-ids x*
(lambda (x*)
(let-values ([(body body-pure?) (Expr body)])
(let-values ([(pre* lhs* rhs* pure?)
(let f ([x* x*] [e* e*])
(if (null? x*)
(values '() '() '() #t)
(let ([x (car x*)])
(let-values ([(e e-pure?) (Expr (car e*))]
[(pre* lhs* rhs* pure?) (f (cdr x*) (cdr e*))])
(if (prelex-referenced/assigned x)
(values pre* (cons x lhs*) (cons e rhs*) (and e-pure? pure?))
(values (if e-pure? pre* (cons e pre*))
lhs* rhs* (and e-pure? pure?)))))))])
(values
(build-seq pre* (build-let preinfo0 preinfo1 lhs* rhs* body))
(and body-pure? pure?))))))]
[(call ,preinfo ,pr ,e* ...)
(let ()
(define (arity-okay? arity n)
(or (not arity)
(ormap (lambda (a)
(or (fx= n a)
(and (fx< a 0) (fx>= n (fx- -1 a)))))
arity)))
(let-values ([(e* pure?) (Expr* e*)])
(values
`(call ,preinfo ,pr ,e* ...)
(and pure?
(all-set? (prim-mask (or proc pure unrestricted discard)) (primref-flags pr))
(arity-okay? (primref-arity pr) (length e*))))))]
[(call ,preinfo ,[e pure?] ,[e* pure?*] ...)
(values `(call ,preinfo ,e ,e* ...) #f)]
[(if ,[e0 e0-pure?] ,[e1 e1-pure?] ,[e2 e2-pure?])
(values `(if ,e0 ,e1 ,e2) (and e0-pure? e1-pure? e2-pure?))]
[(case-lambda ,preinfo ,[cl*] ...)
(values `(case-lambda ,preinfo ,cl* ...) #t)]
[(seq ,[e1 e1-pure?] ,[e2 e2-pure?])
(values `(seq ,e1 ,e2) (and e1-pure? e2-pure?))]
[(set! ,maybe-src ,x ,[e pure?])
(let ([x (prelex-operand x)])
(safe-assert (prelex? x))
(safe-assert (prelex-was-assigned x))
; NB: cpletrec-letrec assumes assignments to unreferenced ids are dropped
(if (prelex-was-referenced x)
(begin
(set-prelex-seen/assigned! x #t)
(values `(set! ,maybe-src ,x ,e) #f))
(if pure? (values `(quote ,(void)) #t) (values `(seq ,e (quote ,(void))) #f))))]
[(letrec ([,x* ,e*] ...) ,body)
(with-initialized-ids x*
(lambda (x*)
(cpletrec-letrec #f x* e* body)))]
[(letrec* ([,x* ,e*] ...) ,body)
(with-initialized-ids x*
(lambda (x*)
(cpletrec-letrec #t x* e* body)))]
[(foreign ,conv ,name ,[e pure?] (,arg-type* ...) ,result-type)
(values `(foreign ,conv ,name ,e (,arg-type* ...) ,result-type)
(and (fx= (optimize-level) 3) pure?))]
[(fcallable ,conv ,[e pure?] (,arg-type* ...) ,result-type)
(values `(fcallable ,conv ,e (,arg-type* ...) ,result-type)
(and (fx= (optimize-level) 3) pure?))]
[(record-ref ,rtd ,type ,index ,[e pure?])
(values `(record-ref ,rtd ,type ,index ,e) #f)]
[(record-set! ,rtd ,type ,index ,[e1 pure1?] ,[e2 pure2?])
(values `(record-set! ,rtd ,type ,index ,e1 ,e2) #f)]
[(record ,rtd ,[rtd-expr rtd-pure?] ,e* ...)
(let-values ([(e* pure?) (Expr* e*)])
(values
`(record ,rtd ,rtd-expr ,e* ...)
(and (and rtd-pure? pure?)
(andmap
(lambda (fld)
(and (not (fld-mutable? fld))
(eq? (filter-foreign-type (fld-type fld)) 'scheme-object)))
(rtd-flds rtd)))))]
[(record-type ,rtd ,e) (Expr e)]
[(record-cd ,rcd ,rtd-expr ,e) (Expr e)]
[(immutable-list (,[e* pure?*] ...) ,[e pure?])
(values `(immutable-list (,e* ...) ,e) pure?)]
[,pr (values pr #t)]
[(moi) (values ir #t)]
[(pariah) (values ir #t)]
[(cte-optimization-loc ,box ,[e pure?])
(values `(cte-optimization-loc ,box ,e) pure?)]
[(profile ,src) (values ir #f)]
[else (sorry! who "unhandled record ~s" ir)])
(CaseLambdaClause : CaseLambdaClause (ir) -> CaseLambdaClause ()
[(clause (,x* ...) ,interface ,body)
(with-initialized-ids x*
(lambda (x*)
(let-values ([(body pure?) (Expr body)])
`(clause (,x* ...) ,interface ,body))))])
(let-values ([(ir pure?) (Expr ir)]) ir))
(lambda (x)
(let ([x (if (eq? ($compile-profile) 'source) (lift-profile-forms x) x)])
(cpletrec x)))
))
Reference in New Issue View Git Blame Copy Permalink