From 983e8b6c00792838127dc2a1e41ac8db371cb637 Mon Sep 17 00:00:00 2001 From: dyb Date: Fri, 27 Oct 2017 23:16:47 -0400 Subject: [PATCH 1/9] =?UTF-8?q?Numerous=20changes=20to=20improve=20registe?= =?UTF-8?q?r/frame=20allocation=20speed=20for=20procedures=20with=20large?= =?UTF-8?q?=20numbers=20of=20variables:=20-=20added=20pass-time=20tracking?= =?UTF-8?q?=20for=20pre-cpnanopass=20passes=20to=20compile.=20=20=20=20=20?= =?UTF-8?q?compile.ss=20-=20added=20inline=20handler=20for=20fxdiv-and-mod?= =?UTF-8?q?=20=20=20=20=20cp0.ss,=20primdata.ss=20-=20changed=20order=20in?= =?UTF-8?q?=20which=20return-point=20operations=20are=20done=20(adjust=20?= =?UTF-8?q?=20=20sfp=20first,=20then=20store=20return=20values,=20then=20r?= =?UTF-8?q?estore=20local=20saves)=20to=20=20=20avoid=20storing=20return?= =?UTF-8?q?=20values=20to=20homes=20beyond=20the=20end=20of=20the=20stack?= =?UTF-8?q?=20=20=20in=20cases=20where=20adjusting=20sfp=20might=20result?= =?UTF-8?q?=20in=20a=20call=20to=20dooverflood.=20=20=20=20=20cpnanopass.s?= =?UTF-8?q?s,=20np-languages.ss=20-=20removed=20unused=20{make-,}asm-retur?= =?UTF-8?q?n-registers=20bindings=20=20=20=20=20cpnanopass.ss=20-=20correc?= =?UTF-8?q?ted=20the=20max-fv=20value=20field=20of=20the=20lambda=20produc?= =?UTF-8?q?ed=20by=20the=20=20=20hand-coded=20bytevector=3D=3F=20handler.?= =?UTF-8?q?=20=20=20=20=20cpnanopass.ss=20-=20reduced=20live-pointer=20and?= =?UTF-8?q?=20inspector=20free-variable=20mask=20computation=20=20=20overh?= =?UTF-8?q?ead=20=20=20=20=20cpnanopass.ss=20-=20moved=20regvec=20cset=20c?= =?UTF-8?q?opies=20to=20driver=20so=20they=20aren't=20copied=20each=20=20?= =?UTF-8?q?=20time=20a=20uvar=20is=20assigned=20to=20a=20register.=20=20re?= =?UTF-8?q?moved=20checks=20for=20=20=20missing=20register=20csets,=20sinc?= =?UTF-8?q?e=20registers=20always=20have=20csets.=20=20=20=20=20cpnanopass?= =?UTF-8?q?.ss=20-=20added=20closure-rep=20else=20clause=20in=20record-ins?= =?UTF-8?q?pector-information!.=20=20=20=20=20cpnanopass.ss=20-=20augmente?= =?UTF-8?q?d=20tree=20representation=20with=20a=20constant=20representatio?= =?UTF-8?q?n=20=20=20for=20full=20trees=20to=20reduce=20the=20overhead=20o?= =?UTF-8?q?f=20manipulating=20trees=20or=20=20=20subtress=20with=20all=20b?= =?UTF-8?q?its=20set.=20=20=20=20=20cpnanopass.ss=20-=20tree-for-each=20no?= =?UTF-8?q?w=20takes=20start=20and=20end=20offsets;=20this=20cuts=20the=20?= =?UTF-8?q?=20=20cost=20of=20traversing=20and=20applying=20the=20action=20?= =?UTF-8?q?when=20the=20range=20of=20=20=20applicable=20offsets=20is=20oth?= =?UTF-8?q?er=20than=200..tree-size.=20=20=20=20=20cpnanopass.ss=20-=20int?= =?UTF-8?q?roduced=20the=20notion=20of=20poison=20variables=20to=20reduce?= =?UTF-8?q?=20the=20cost=20of=20=20=20register/frame=20allocation=20for=20?= =?UTF-8?q?procedures=20with=20large=20sets=20of=20local=20=20=20variables?= =?UTF-8?q?.=20=20When=20the=20number=20of=20local=20variables=20exceeds?= =?UTF-8?q?=20a=20given=20=20=20limit=20(currently=20hardwired=20to=201000?= =?UTF-8?q?),=20each=20variable=20with=20a=20large=20=20=20live=20range=20?= =?UTF-8?q?is=20considered=20poison.=20=20A=20reasonable=20set=20of=20vari?= =?UTF-8?q?ables=20=20=20with=20large=20live=20ranges=20(the=20set=20of=20?= =?UTF-8?q?poison=20variables)=20is=20computed=20=20=20by=20successive=20a?= =?UTF-8?q?pproximation=20to=20avoid=20excessive=20overhead.=20=20Poison?= =?UTF-8?q?=20=20=20variables=20directly=20conflict=20with=20all=20spillab?= =?UTF-8?q?les,=20and=20all=20non-poison=20=20=20spillables=20indirectly?= =?UTF-8?q?=20conflict=20with=20all=20poison=20spillables=20through=20=20?= =?UTF-8?q?=20a=20shared=20poison-cset.=20=20Thus=20poison=20variables=20c?= =?UTF-8?q?annot=20live=20in=20the=20=20=20same=20location=20as=20any=20ot?= =?UTF-8?q?her=20variable,=20i.e.,=20they=20poison=20the=20location.=20=20?= =?UTF-8?q?=20Conflicts=20between=20frame=20locations=20and=20poison=20var?= =?UTF-8?q?iables=20are=20handled=20=20=20normally,=20which=20allows=20poi?= =?UTF-8?q?son=20variables=20to=20be=20assigned=20to=20=20=20move-related?= =?UTF-8?q?=20frame=20homes.=20=20Poison=20variables=20are=20spilled=20pri?= =?UTF-8?q?or=20to=20=20=20register=20allocation,=20so=20conflicts=20betwe?= =?UTF-8?q?en=20registers=20and=20poison=20=20=20variables=20are=20not=20r?= =?UTF-8?q?epresented.=20=20move=20relations=20between=20poison=20=20=20va?= =?UTF-8?q?riables=20and=20frame=20variables=20are=20recorded=20as=20usual?= =?UTF-8?q?,=20but=20other=20=20=20move=20relations=20involving=20poison?= =?UTF-8?q?=20variables=20are=20not=20recorded.=20=20=20=20=20cpnanopass.s?= =?UTF-8?q?s,=20np-languages.ss=20-=20changed=20the=20way=20a=20uvar's=20d?= =?UTF-8?q?egree=20is=20decremented=20by=20remove-victim!.=20=20=20instead?= =?UTF-8?q?=20of=20checking=20for=20a=20conflict=20between=20each=20pair?= =?UTF-8?q?=20of=20victim=20=20=20and=20keeper=20and=20decrementing=20when?= =?UTF-8?q?=20the=20conflict=20is=20found,=20remove-victim!=20=20=20now=20?= =?UTF-8?q?decrements=20the=20degree=20of=20each=20var=20in=20each=20victi?= =?UTF-8?q?m's=20conflict=20=20=20set.=20=20while=20this=20might=20decreme?= =?UTF-8?q?nt=20other=20victims'=20degrees=20unnecessarily,=20=20=20it=20c?= =?UTF-8?q?an=20be=20much=20less=20expensive=20when=20large=20numbers=20of?= =?UTF-8?q?=20variables=20are=20=20=20involved,=20since=20the=20number=20o?= =?UTF-8?q?f=20conflicts=20between=20two=20non-poison=20=20=20variables=20?= =?UTF-8?q?should=20be=20small=20due=20to=20the=20selection=20process=20fo?= =?UTF-8?q?r=20=20=20(non-)poison=20variables=20and=20the=20fact=20that=20?= =?UTF-8?q?the=20unspillables=20introduced=20=20=20by=20instruction=20sele?= =?UTF-8?q?ction=20should=20also=20have=20few=20conflicts.=20=20That=20=20?= =?UTF-8?q?=20is,=20it=20reduces=20the=20worst-case=20complexity=20of=20de?= =?UTF-8?q?crementing=20degrees=20=20=20from=20O(n^2)=20to=20O(n).=20=20?= =?UTF-8?q?=20=20=20cpnanopass.ss=20-=20took=20advice=20in=20compute-degre?= =?UTF-8?q?e!=20comment=20to=20increment=20the=20uvars=20in=20=20=20each?= =?UTF-8?q?=20registers=20csets=20rather=20than=20looping=20over=20the=20r?= =?UTF-8?q?egisters=20for=20=20=20each=20uvar=20asking=20whether=20the=20r?= =?UTF-8?q?egister=20conflicts=20with=20the=20uvar.=20=20=20=20=20cpnanopa?= =?UTF-8?q?ss.ss=20-=20assign-new-frame!=20now=20zeros=20out=20save-weight?= =?UTF-8?q?=20for=20local=20saves,=20since=20=20=20once=20they=20are=20exp?= =?UTF-8?q?licitly=20saved=20and=20restored,=20they=20are=20no=20longer=20?= =?UTF-8?q?=20=20call-live=20and=20thus=20have=20no=20save=20cost.=20=20?= =?UTF-8?q?=20=20=20cpnanopass.ss=20-=20desensitized=20the=20let-values=20?= =?UTF-8?q?source-caching=20timing=20test=20slightly=20=20=20=20=208.ms=20?= =?UTF-8?q?-=20updated=20allx,=20bullyx=20patches=20=20=20=20=20patch*?= original commit: 3a49d0193ae57b8e31ec6a00b5b49db31a52373f --- LOG | 76 +++- mats/8.ms | 4 +- mats/patch-compile-0-f-f-t | 50 ++- mats/patch-compile-0-f-t-f | 4 +- mats/patch-compile-0-t-f-f | 4 +- mats/patch-compile-0-t-f-t | 44 ++ mats/patch-compile-0-t-t-f | 28 +- mats/patch-interpret-0-f-f-f | 4 +- mats/patch-interpret-0-f-t-f | 4 +- mats/patch-interpret-0-t-f-f | 36 +- mats/patch-interpret-0-t-t-f | 36 +- mats/patch-interpret-3-f-f-f | 4 +- mats/patch-interpret-3-f-t-f | 4 +- mats/patch-interpret-3-t-f-f | 4 +- mats/patch-interpret-3-t-t-f | 4 +- s/compile.ss | 12 +- s/cp0.ss | 14 + s/cpnanopass.ss | 810 ++++++++++++++++++++--------------- s/np-languages.ss | 10 +- s/primdata.ss | 2 +- 20 files changed, 738 insertions(+), 416 deletions(-) diff --git a/LOG b/LOG index 788aebebaf..081015fad8 100644 --- a/LOG +++ b/LOG @@ -645,4 +645,78 @@ makefiles/Makefile-release_notes.in (renamed from release_notes/Makefile), makefiles/Makefile - +- added pass-time tracking for pre-cpnanopass passes to compile. + compile.ss +- added inline handler for fxdiv-and-mod + cp0.ss, primdata.ss +- changed order in which return-point operations are done (adjust + sfp first, then store return values, then restore local saves) to + avoid storing return values to homes beyond the end of the stack + in cases where adjusting sfp might result in a call to dooverflood. + cpnanopass.ss, np-languages.ss +- removed unused {make-,}asm-return-registers bindings + cpnanopass.ss +- corrected the max-fv value field of the lambda produced by the + hand-coded bytevector=? handler. + cpnanopass.ss +- reduced live-pointer and inspector free-variable mask computation + overhead for live masks. + cpnanopass.ss +- moved regvec cset copies to driver so they aren't copied each + time a uvar is assigned to a register. removed checks for + missing register csets, since registers always have csets. + cpnanopass.ss +- added closure-rep else clause in record-inspector-information!. + cpnanopass.ss +- augmented tree representation with a constant representation + for full trees to reduce the overhead of manipulating trees or + subtress with all bits set. + cpnanopass.ss +- tree-for-each now takes start and end offsets; this cuts the + cost of traversing and applying the action when the range of + applicable offsets is other than 0..tree-size. + cpnanopass.ss +- introduced the notion of poison variables to reduce the cost of + register/frame allocation for procedures with large sets of local + variables. When the number of local variables exceeds a given + limit (currently hardwired to 1000), each variable with a large + live range is considered poison. A reasonable set of variables + with large live ranges (the set of poison variables) is computed + by successive approximation to avoid excessive overhead. Poison + variables directly conflict with all spillables, and all non-poison + spillables indirectly conflict with all poison spillables through + a shared poison-cset. Thus poison variables cannot live in the + same location as any other variable, i.e., they poison the location. + Conflicts between frame locations and poison variables are handled + normally, which allows poison variables to be assigned to + move-related frame homes. Poison variables are spilled prior to + register allocation, so conflicts between registers and poison + variables are not represented. move relations between poison + variables and frame variables are recorded as usual, but other + move relations involving poison variables are not recorded. + cpnanopass.ss, np-languages.ss +- changed the way a uvar's degree is decremented by remove-victim!. + instead of checking for a conflict between each pair of victim + and keeper and decrementing when the conflict is found, remove-victim! + now decrements the degree of each var in each victim's conflict + set. while this might decrement other victims' degrees unnecessarily, + it can be much less expensive when large numbers of variables are + involved, since the number of conflicts between two non-poison + variables should be small due to the selection process for + (non-)poison variables and the fact that the unspillables introduced + by instruction selection should also have few conflicts. That + is, it reduces the worst-case complexity of decrementing degrees + from O(n^2) to O(n). + cpnanopass.ss +- took advice in compute-degree! comment to increment the uvars in + each registers csets rather than looping over the registers for + each uvar asking whether the register conflicts with the uvar. + cpnanopass.ss +- assign-new-frame! now zeros out save-weight for local saves, since + once they are explicitly saved and restored, they are no longer + call-live and thus have no save cost. + cpnanopass.ss +- desensitized the let-values source-caching timing test slightly + 8.ms +- updated allx, bullyx patches + patch* diff --git a/mats/8.ms b/mats/8.ms index 9e4679a33d..d7d9b97914 100644 --- a/mats/8.ms +++ b/mats/8.ms @@ -11094,7 +11094,7 @@ (pretty-print (make-expr n))) 'truncate) (let ([start (current-time)]) - (load "testfile.ss") + (load "testfile.ss" expand) (let ([delta (time-difference (current-time) start)]) (+ (time-second delta) (* 1e-9 (time-nanosecond delta)))))) @@ -11102,7 +11102,7 @@ (let loop ([tries 3]) (when (zero? tries) (error 'source-cache-test "loading lots of `let-values` forms seems to take too long")) - (or (> (* 20 (time-expr 100)) + (or (> (* 30 (time-expr 100)) (time-expr 1000)) (loop (sub1 tries))))) diff --git a/mats/patch-compile-0-f-f-t b/mats/patch-compile-0-f-f-t index 0384a2b3f0..2a8173be31 100644 --- a/mats/patch-compile-0-f-f-t +++ b/mats/patch-compile-0-f-f-t @@ -1,7 +1,49 @@ -*** errors-compile-0-f-f-f 2017-06-06 15:52:54.089820649 -0400 ---- errors-compile-0-f-f-t 2017-06-06 15:55:15.167428881 -0400 +*** errors-compile-0-f-f-f 2017-10-26 23:57:58.000000000 -0400 +--- errors-compile-0-f-f-t 2017-10-27 00:08:47.000000000 -0400 *************** -*** 8461,8473 **** +*** 3631,3637 **** + misc.mo:Expected error in mat compute-composition: "compute-composition: invalid generation -1". + misc.mo:Expected error in mat compute-composition: "compute-composition: invalid generation "static"". + misc.mo:Expected error in mat make-object-finder: "make-object-finder: 17 is not a procedure". +! misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid generation 5". + misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid generation oldgen". + misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid generation -1". + misc.mo:Expected error in mat make-object-finder: "incorrect number of arguments to #". +--- 3631,3637 ---- + misc.mo:Expected error in mat compute-composition: "compute-composition: invalid generation -1". + misc.mo:Expected error in mat compute-composition: "compute-composition: invalid generation "static"". + misc.mo:Expected error in mat make-object-finder: "make-object-finder: 17 is not a procedure". +! misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid generation 7". + misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid generation oldgen". + misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid generation -1". + misc.mo:Expected error in mat make-object-finder: "incorrect number of arguments to #". +*************** +*** 7113,7123 **** + 7.mo:Expected error in mat sstats: "set-sstats-gc-bytes!: twelve is not an exact integer". + 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation yuk". + 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation -1". +! 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation 5". + 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation ". + 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation #f". +! 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation 5". +! 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation 5". + 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu". + 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu". + 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu". +--- 7113,7123 ---- + 7.mo:Expected error in mat sstats: "set-sstats-gc-bytes!: twelve is not an exact integer". + 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation yuk". + 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation -1". +! 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation 7". + 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation ". + 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation #f". +! 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation 7". +! 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation 7". + 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu". + 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu". + 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu". +*************** +*** 8523,8535 **** fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum". fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum". fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum". @@ -15,7 +57,7 @@ fx.mo:Expected error in mat r6rs:fx*: "fx*: is not a fixnum". fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum". fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum". ---- 8461,8473 ---- +--- 8523,8535 ---- fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum". fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum". fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum". diff --git a/mats/patch-compile-0-f-t-f b/mats/patch-compile-0-f-t-f index 24fe5550ba..b87b3cb5b0 100644 --- a/mats/patch-compile-0-f-t-f +++ b/mats/patch-compile-0-f-t-f @@ -1,5 +1,5 @@ -*** errors-compile-0-f-f-f 2017-10-13 12:34:00.000000000 -0400 ---- errors-compile-0-f-t-f 2017-10-13 11:59:38.000000000 -0400 +*** errors-compile-0-f-f-f 2017-10-27 11:03:39.000000000 -0400 +--- errors-compile-0-f-t-f 2017-10-27 10:30:43.000000000 -0400 *************** *** 125,131 **** 3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable a". diff --git a/mats/patch-compile-0-t-f-f b/mats/patch-compile-0-t-f-f index e5e7d96695..51fb0d5aba 100644 --- a/mats/patch-compile-0-t-f-f +++ b/mats/patch-compile-0-t-f-f @@ -1,5 +1,5 @@ -*** errors-compile-0-f-f-f 2017-10-13 12:34:00.000000000 -0400 ---- errors-compile-0-t-f-f 2017-10-13 12:07:22.000000000 -0400 +*** errors-compile-0-f-f-f 2017-10-27 11:03:39.000000000 -0400 +--- errors-compile-0-t-f-f 2017-10-27 10:38:13.000000000 -0400 *************** *** 93,99 **** 3.mo:Expected error in mat case-lambda: "incorrect number of arguments to #". diff --git a/mats/patch-compile-0-t-f-t b/mats/patch-compile-0-t-f-t index e69de29bb2..f7ae882d19 100644 --- a/mats/patch-compile-0-t-f-t +++ b/mats/patch-compile-0-t-f-t @@ -0,0 +1,44 @@ +*** errors-compile-0-t-f-f 2017-10-27 00:19:35.000000000 -0400 +--- errors-compile-0-t-f-t 2017-10-27 00:02:11.000000000 -0400 +*************** +*** 3631,3637 **** + misc.mo:Expected error in mat compute-composition: "compute-composition: invalid generation -1". + misc.mo:Expected error in mat compute-composition: "compute-composition: invalid generation "static"". + misc.mo:Expected error in mat make-object-finder: "make-object-finder: 17 is not a procedure". +! misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid generation 5". + misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid generation oldgen". + misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid generation -1". + misc.mo:Expected error in mat make-object-finder: "incorrect number of arguments to #". +--- 3631,3637 ---- + misc.mo:Expected error in mat compute-composition: "compute-composition: invalid generation -1". + misc.mo:Expected error in mat compute-composition: "compute-composition: invalid generation "static"". + misc.mo:Expected error in mat make-object-finder: "make-object-finder: 17 is not a procedure". +! misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid generation 2". + misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid generation oldgen". + misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid generation -1". + misc.mo:Expected error in mat make-object-finder: "incorrect number of arguments to #". +*************** +*** 7113,7123 **** + 7.mo:Expected error in mat sstats: "set-sstats-gc-bytes!: twelve is not an exact integer". + 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation yuk". + 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation -1". +! 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation 5". + 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation ". + 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation #f". +! 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation 5". +! 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation 5". + 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu". + 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu". + 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu". +--- 7113,7123 ---- + 7.mo:Expected error in mat sstats: "set-sstats-gc-bytes!: twelve is not an exact integer". + 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation yuk". + 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation -1". +! 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation 2". + 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation ". + 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation #f". +! 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation 2". +! 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation 2". + 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu". + 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu". + 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu". diff --git a/mats/patch-compile-0-t-t-f b/mats/patch-compile-0-t-t-f index 470388b9d4..614e350397 100644 --- a/mats/patch-compile-0-t-t-f +++ b/mats/patch-compile-0-t-t-f @@ -1,5 +1,5 @@ -*** errors-compile-0-t-f-f 2017-06-06 16:02:22.028311707 -0400 ---- errors-compile-0-t-t-f 2017-06-06 16:07:14.499665698 -0400 +*** errors-compile-0-t-f-f 2017-10-27 00:19:35.000000000 -0400 +--- errors-compile-0-t-t-f 2017-10-27 00:13:23.000000000 -0400 *************** *** 144,150 **** 3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable b". @@ -18,7 +18,7 @@ 3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable c". 3.mo:Expected warning in mat cpvalid: "possible attempt to reference undefined variable x". *************** -*** 3645,3651 **** +*** 3673,3679 **** misc.mo:Expected error in mat cpletrec: "foreign-procedure: no entry for "foo"". misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable q". misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable bar". @@ -26,7 +26,7 @@ misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable b". misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable b". misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable a". ---- 3645,3651 ---- +--- 3673,3679 ---- misc.mo:Expected error in mat cpletrec: "foreign-procedure: no entry for "foo"". misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable q". misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable bar". @@ -35,7 +35,7 @@ misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable b". misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable a". *************** -*** 7095,7102 **** +*** 7123,7130 **** 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu". 7.mo:Expected error in mat error: "a: hit me!". 7.mo:Expected error in mat error: "f: n is 0". @@ -44,7 +44,7 @@ record.mo:Expected error in mat record2: "invalid value 3 for foreign type double-float". record.mo:Expected error in mat record2: "3 is not of type #". record.mo:Expected error in mat record2: "make-record-type: invalid field list ((immutable double-float a) . b)". ---- 7095,7102 ---- +--- 7123,7130 ---- 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu". 7.mo:Expected error in mat error: "a: hit me!". 7.mo:Expected error in mat error: "f: n is 0". @@ -54,7 +54,7 @@ record.mo:Expected error in mat record2: "3 is not of type #". record.mo:Expected error in mat record2: "make-record-type: invalid field list ((immutable double-float a) . b)". *************** -*** 7104,7118 **** +*** 7132,7146 **** record.mo:Expected error in mat type-descriptor: "invalid syntax (type-descriptor 3)". record.mo:Expected error in mat type-descriptor: "type-descriptor: unrecognized record car". record.mo:Expected error in mat record3: "variable set-fudge-a! is not bound". @@ -70,7 +70,7 @@ record.mo:Expected error in mat record9: "record-reader: invalid input #f". record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge". record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge". ---- 7104,7118 ---- +--- 7132,7146 ---- record.mo:Expected error in mat type-descriptor: "invalid syntax (type-descriptor 3)". record.mo:Expected error in mat type-descriptor: "type-descriptor: unrecognized record car". record.mo:Expected error in mat record3: "variable set-fudge-a! is not bound". @@ -87,7 +87,7 @@ record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge". record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge". *************** -*** 7125,7150 **** +*** 7153,7178 **** record.mo:Expected error in mat record10: "read: unresolvable cycle constructing record of type # at char 3 of #". record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type # at char 3 of #". record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type # at char 3 of #". @@ -114,7 +114,7 @@ record.mo:Expected error in mat foreign-data: "foreign-alloc: 0 is not a positive fixnum". record.mo:Expected error in mat foreign-data: "foreign-alloc: is not a positive fixnum". record.mo:Expected error in mat foreign-data: "foreign-alloc: -5 is not a positive fixnum". ---- 7125,7150 ---- +--- 7153,7178 ---- record.mo:Expected error in mat record10: "read: unresolvable cycle constructing record of type # at char 3 of #". record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type # at char 3 of #". record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type # at char 3 of #". @@ -142,7 +142,7 @@ record.mo:Expected error in mat foreign-data: "foreign-alloc: is not a positive fixnum". record.mo:Expected error in mat foreign-data: "foreign-alloc: -5 is not a positive fixnum". *************** -*** 7275,7313 **** +*** 7303,7341 **** record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)". record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)". record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #". @@ -182,7 +182,7 @@ record.mo:Expected error in mat record?: "record?: 4 is not a record type descriptor". record.mo:Expected error in mat record?: "record?: a is not a record type descriptor". record.mo:Expected error in mat record?: "record?: #(1) is not a record type descriptor". ---- 7275,7313 ---- +--- 7303,7341 ---- record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)". record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)". record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #". @@ -223,7 +223,7 @@ record.mo:Expected error in mat record?: "record?: a is not a record type descriptor". record.mo:Expected error in mat record?: "record?: #(1) is not a record type descriptor". *************** -*** 7333,7368 **** +*** 7361,7396 **** record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: record constructor descriptor # is not for parent of record type #". record.mo:Expected error in mat r6rs-records-procedural: "make-record-type-descriptor: cannot extend sealed record type #". record.mo:Expected error in mat r6rs-records-syntactic: "invalid syntax point". @@ -260,7 +260,7 @@ record.mo:Expected error in mat r6rs-records-syntactic: "record-rtd: # is not a record". record.mo:Expected error in mat r6rs-records-syntactic: "record-rtd: # is not a record". record.mo:Expected error in mat r6rs-records-syntactic: "parent record type is sealed ex3". ---- 7333,7368 ---- +--- 7361,7396 ---- record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: record constructor descriptor # is not for parent of record type #". record.mo:Expected error in mat r6rs-records-procedural: "make-record-type-descriptor: cannot extend sealed record type #". record.mo:Expected error in mat r6rs-records-syntactic: "invalid syntax point". diff --git a/mats/patch-interpret-0-f-f-f b/mats/patch-interpret-0-f-f-f index a30f06ad6f..819620b98b 100644 --- a/mats/patch-interpret-0-f-f-f +++ b/mats/patch-interpret-0-f-f-f @@ -1,5 +1,5 @@ -*** errors-compile-0-f-f-f 2017-10-13 12:34:00.000000000 -0400 ---- errors-interpret-0-f-f-f 2017-10-13 12:15:36.000000000 -0400 +*** errors-compile-0-f-f-f 2017-10-27 11:03:39.000000000 -0400 +--- errors-interpret-0-f-f-f 2017-10-27 10:46:02.000000000 -0400 *************** *** 1,7 **** primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure". diff --git a/mats/patch-interpret-0-f-t-f b/mats/patch-interpret-0-f-t-f index 80fc6e3fc9..a04fdcae56 100644 --- a/mats/patch-interpret-0-f-t-f +++ b/mats/patch-interpret-0-f-t-f @@ -1,5 +1,5 @@ -*** errors-compile-0-f-t-f 2017-10-13 11:59:38.000000000 -0400 ---- errors-interpret-0-f-t-f 2017-10-13 12:23:52.000000000 -0400 +*** errors-compile-0-f-t-f 2017-10-27 10:30:43.000000000 -0400 +--- errors-interpret-0-f-t-f 2017-10-27 10:54:02.000000000 -0400 *************** *** 1,7 **** primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure". diff --git a/mats/patch-interpret-0-t-f-f b/mats/patch-interpret-0-t-f-f index 356b45f77d..6fb81d4739 100644 --- a/mats/patch-interpret-0-t-f-f +++ b/mats/patch-interpret-0-t-f-f @@ -1,5 +1,5 @@ -*** errors-compile-0-t-f-f 2017-06-06 16:02:22.028311707 -0400 ---- errors-interpret-0-t-f-f 2017-06-06 17:00:22.766486846 -0400 +*** errors-compile-0-t-f-f 2017-10-27 00:19:35.000000000 -0400 +--- errors-interpret-0-t-f-f 2017-10-27 01:28:06.000000000 -0400 *************** *** 1,7 **** primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure". @@ -169,7 +169,7 @@ 3.mo:Expected error in mat letrec: "variable f is not bound". 3.mo:Expected error in mat letrec: "attempt to reference undefined variable a". *************** -*** 4004,4019 **** +*** 4032,4047 **** 6.mo:Expected error in mat pretty-print: "incorrect number of arguments to #". 6.mo:Expected error in mat pretty-print: "pretty-format: 3 is not a symbol". 6.mo:Expected error in mat pretty-print: "pretty-format: invalid format (bad 0 ... ... 0 format)". @@ -186,9 +186,9 @@ 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "abc~s" in call to fprintf at line 1, char 29 of testfile.ss". 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~%~abc~adef~ag~s~~~%" in call to fprintf at line 1, char 29 of testfile.ss". 6.mo:Expected error in mat print-parameters: "write: cycle detected; proceeding with (print-graph #t)". ---- 4010,4019 ---- +--- 4038,4047 ---- *************** -*** 6959,6965 **** +*** 6987,6993 **** 7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for testfile-mc-1a.ss: no such file or directory 7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in maybe-compile-library: failed for "testfile-mc-1a.ss": no such file or directory 7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in maybe-compile-library: file "testfile-mc-1a.ss" not found in source directories @@ -196,7 +196,7 @@ 7.mo:Expected error in mat eval: "interpret: 7 is not an environment". 7.mo:Expected error in mat eval: "compile: 7 is not an environment". 7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment". ---- 6959,6965 ---- +--- 6987,6993 ---- 7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for testfile-mc-1a.ss: no such file or directory 7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in maybe-compile-library: failed for "testfile-mc-1a.ss": no such file or directory 7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in maybe-compile-library: file "testfile-mc-1a.ss" not found in source directories @@ -205,7 +205,7 @@ 7.mo:Expected error in mat eval: "compile: 7 is not an environment". 7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment". *************** -*** 7286,7292 **** +*** 7314,7320 **** record.mo:Expected error in mat record25: "invalid value #\9 for foreign type uptr". record.mo:Expected error in mat record25: "invalid value 10 for foreign type float". record.mo:Expected error in mat record25: "invalid value 11.0+0.0i for foreign type double". @@ -213,7 +213,7 @@ record.mo:Expected error in mat record25: "invalid value 12.0 for foreign type long-long". record.mo:Expected error in mat record25: "invalid value 13.0 for foreign type unsigned-long-long". record.mo:Expected error in mat record25: "invalid value 3.0 for foreign type int". ---- 7286,7292 ---- +--- 7314,7320 ---- record.mo:Expected error in mat record25: "invalid value #\9 for foreign type uptr". record.mo:Expected error in mat record25: "invalid value 10 for foreign type float". record.mo:Expected error in mat record25: "invalid value 11.0+0.0i for foreign type double". @@ -222,7 +222,7 @@ record.mo:Expected error in mat record25: "invalid value 13.0 for foreign type unsigned-long-long". record.mo:Expected error in mat record25: "invalid value 3.0 for foreign type int". *************** -*** 9224,9248 **** +*** 9286,9310 **** foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo". foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo". foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo". @@ -248,7 +248,7 @@ foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure argument type specifier booleen". foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure argument type specifier integer-34". foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure result type specifier chare". ---- 9224,9248 ---- +--- 9286,9310 ---- foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo". foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo". foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo". @@ -275,7 +275,7 @@ foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure argument type specifier integer-34". foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure result type specifier chare". *************** -*** 9255,9286 **** +*** 9317,9348 **** foreign.mo:Expected error in mat foreign-sizeof: "incorrect number of arguments to #". foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier i-am-not-a-type". foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier 1". @@ -308,7 +308,7 @@ foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #". foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #". foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #". ---- 9255,9286 ---- +--- 9317,9348 ---- foreign.mo:Expected error in mat foreign-sizeof: "incorrect number of arguments to #". foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier i-am-not-a-type". foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier 1". @@ -342,7 +342,7 @@ foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #". foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #". *************** -*** 9288,9313 **** +*** 9350,9375 **** foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #". foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #". foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #". @@ -369,7 +369,7 @@ foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #". foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #". foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #". ---- 9288,9313 ---- +--- 9350,9375 ---- foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #". foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #". foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #". @@ -397,7 +397,7 @@ foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #". foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #". *************** -*** 9318,9352 **** +*** 9380,9414 **** foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #". foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #". foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #". @@ -433,7 +433,7 @@ foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #". foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #". foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #". ---- 9318,9352 ---- +--- 9380,9414 ---- foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #". foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #". foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #". @@ -470,7 +470,7 @@ foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #". foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #". *************** -*** 9939,9948 **** +*** 10001,10010 **** exceptions.mo:Expected error in mat assert: "failed assertion (memq (quote b) (quote (1 2 a 3 4)))". exceptions.mo:Expected error in mat assert: "failed assertion (q ...)". exceptions.mo:Expected error in mat assert: "failed assertion (andmap symbol? (syntax (x ...)))". @@ -481,7 +481,7 @@ oop.mo:Expected error in mat oop: "m1: not applicable to 17". oop.mo:Expected error in mat oop: "variable -x1 is not bound". oop.mo:Expected error in mat oop: "variable -x1-set! is not bound". ---- 9939,9948 ---- +--- 10001,10010 ---- exceptions.mo:Expected error in mat assert: "failed assertion (memq (quote b) (quote (1 2 a 3 4)))". exceptions.mo:Expected error in mat assert: "failed assertion (q ...)". exceptions.mo:Expected error in mat assert: "failed assertion (andmap symbol? (syntax (x ...)))". diff --git a/mats/patch-interpret-0-t-t-f b/mats/patch-interpret-0-t-t-f index 47aa88bf0f..6c9670d3f5 100644 --- a/mats/patch-interpret-0-t-t-f +++ b/mats/patch-interpret-0-t-t-f @@ -1,5 +1,5 @@ -*** errors-compile-0-t-t-f 2017-06-06 16:07:14.499665698 -0400 ---- errors-interpret-0-t-t-f 2017-06-06 17:05:55.514674822 -0400 +*** errors-compile-0-t-t-f 2017-10-27 00:13:23.000000000 -0400 +--- errors-interpret-0-t-t-f 2017-10-27 01:33:39.000000000 -0400 *************** *** 1,7 **** primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure". @@ -169,7 +169,7 @@ 3.mo:Expected error in mat letrec: "variable f is not bound". 3.mo:Expected error in mat letrec: "attempt to reference undefined variable a". *************** -*** 4004,4019 **** +*** 4032,4047 **** 6.mo:Expected error in mat pretty-print: "incorrect number of arguments to #". 6.mo:Expected error in mat pretty-print: "pretty-format: 3 is not a symbol". 6.mo:Expected error in mat pretty-print: "pretty-format: invalid format (bad 0 ... ... 0 format)". @@ -186,9 +186,9 @@ 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "abc~s" in call to fprintf at line 1, char 29 of testfile.ss". 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~%~abc~adef~ag~s~~~%" in call to fprintf at line 1, char 29 of testfile.ss". 6.mo:Expected error in mat print-parameters: "write: cycle detected; proceeding with (print-graph #t)". ---- 4010,4019 ---- +--- 4038,4047 ---- *************** -*** 6959,6965 **** +*** 6987,6993 **** 7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for testfile-mc-1a.ss: no such file or directory 7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in maybe-compile-library: failed for "testfile-mc-1a.ss": no such file or directory 7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in maybe-compile-library: file "testfile-mc-1a.ss" not found in source directories @@ -196,7 +196,7 @@ 7.mo:Expected error in mat eval: "interpret: 7 is not an environment". 7.mo:Expected error in mat eval: "compile: 7 is not an environment". 7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment". ---- 6959,6965 ---- +--- 6987,6993 ---- 7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for testfile-mc-1a.ss: no such file or directory 7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in maybe-compile-library: failed for "testfile-mc-1a.ss": no such file or directory 7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in maybe-compile-library: file "testfile-mc-1a.ss" not found in source directories @@ -205,7 +205,7 @@ 7.mo:Expected error in mat eval: "compile: 7 is not an environment". 7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment". *************** -*** 7095,7102 **** +*** 7123,7130 **** 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu". 7.mo:Expected error in mat error: "a: hit me!". 7.mo:Expected error in mat error: "f: n is 0". @@ -214,7 +214,7 @@ record.mo:Expected error in mat record2: "invalid value 3 for foreign type double-float". record.mo:Expected error in mat record2: "3 is not of type #". record.mo:Expected error in mat record2: "make-record-type: invalid field list ((immutable double-float a) . b)". ---- 7095,7102 ---- +--- 7123,7130 ---- 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu". 7.mo:Expected error in mat error: "a: hit me!". 7.mo:Expected error in mat error: "f: n is 0". @@ -224,7 +224,7 @@ record.mo:Expected error in mat record2: "3 is not of type #". record.mo:Expected error in mat record2: "make-record-type: invalid field list ((immutable double-float a) . b)". *************** -*** 7104,7118 **** +*** 7132,7146 **** record.mo:Expected error in mat type-descriptor: "invalid syntax (type-descriptor 3)". record.mo:Expected error in mat type-descriptor: "type-descriptor: unrecognized record car". record.mo:Expected error in mat record3: "variable set-fudge-a! is not bound". @@ -240,7 +240,7 @@ record.mo:Expected error in mat record9: "record-reader: invalid input #f". record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge". record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge". ---- 7104,7118 ---- +--- 7132,7146 ---- record.mo:Expected error in mat type-descriptor: "invalid syntax (type-descriptor 3)". record.mo:Expected error in mat type-descriptor: "type-descriptor: unrecognized record car". record.mo:Expected error in mat record3: "variable set-fudge-a! is not bound". @@ -257,7 +257,7 @@ record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge". record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge". *************** -*** 7125,7150 **** +*** 7153,7178 **** record.mo:Expected error in mat record10: "read: unresolvable cycle constructing record of type # at char 3 of #". record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type # at char 3 of #". record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type # at char 3 of #". @@ -284,7 +284,7 @@ record.mo:Expected error in mat foreign-data: "foreign-alloc: 0 is not a positive fixnum". record.mo:Expected error in mat foreign-data: "foreign-alloc: is not a positive fixnum". record.mo:Expected error in mat foreign-data: "foreign-alloc: -5 is not a positive fixnum". ---- 7125,7150 ---- +--- 7153,7178 ---- record.mo:Expected error in mat record10: "read: unresolvable cycle constructing record of type # at char 3 of #". record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type # at char 3 of #". record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type # at char 3 of #". @@ -312,7 +312,7 @@ record.mo:Expected error in mat foreign-data: "foreign-alloc: is not a positive fixnum". record.mo:Expected error in mat foreign-data: "foreign-alloc: -5 is not a positive fixnum". *************** -*** 7275,7313 **** +*** 7303,7341 **** record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)". record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)". record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #". @@ -352,7 +352,7 @@ record.mo:Expected error in mat record?: "record?: 4 is not a record type descriptor". record.mo:Expected error in mat record?: "record?: a is not a record type descriptor". record.mo:Expected error in mat record?: "record?: #(1) is not a record type descriptor". ---- 7275,7313 ---- +--- 7303,7341 ---- record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)". record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)". record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #". @@ -393,7 +393,7 @@ record.mo:Expected error in mat record?: "record?: a is not a record type descriptor". record.mo:Expected error in mat record?: "record?: #(1) is not a record type descriptor". *************** -*** 7333,7368 **** +*** 7361,7396 **** record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: record constructor descriptor # is not for parent of record type #". record.mo:Expected error in mat r6rs-records-procedural: "make-record-type-descriptor: cannot extend sealed record type #". record.mo:Expected error in mat r6rs-records-syntactic: "invalid syntax point". @@ -430,7 +430,7 @@ record.mo:Expected error in mat r6rs-records-syntactic: "record-rtd: # is not a record". record.mo:Expected error in mat r6rs-records-syntactic: "record-rtd: # is not a record". record.mo:Expected error in mat r6rs-records-syntactic: "parent record type is sealed ex3". ---- 7333,7368 ---- +--- 7361,7396 ---- record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: record constructor descriptor # is not for parent of record type #". record.mo:Expected error in mat r6rs-records-procedural: "make-record-type-descriptor: cannot extend sealed record type #". record.mo:Expected error in mat r6rs-records-syntactic: "invalid syntax point". @@ -468,7 +468,7 @@ record.mo:Expected error in mat r6rs-records-syntactic: "record-rtd: # is not a record". record.mo:Expected error in mat r6rs-records-syntactic: "parent record type is sealed ex3". *************** -*** 9939,9948 **** +*** 10001,10010 **** exceptions.mo:Expected error in mat assert: "failed assertion (memq (quote b) (quote (1 2 a 3 4)))". exceptions.mo:Expected error in mat assert: "failed assertion (q ...)". exceptions.mo:Expected error in mat assert: "failed assertion (andmap symbol? (syntax (x ...)))". @@ -479,7 +479,7 @@ oop.mo:Expected error in mat oop: "m1: not applicable to 17". oop.mo:Expected error in mat oop: "variable -x1 is not bound". oop.mo:Expected error in mat oop: "variable -x1-set! is not bound". ---- 9939,9948 ---- +--- 10001,10010 ---- exceptions.mo:Expected error in mat assert: "failed assertion (memq (quote b) (quote (1 2 a 3 4)))". exceptions.mo:Expected error in mat assert: "failed assertion (q ...)". exceptions.mo:Expected error in mat assert: "failed assertion (andmap symbol? (syntax (x ...)))". diff --git a/mats/patch-interpret-3-f-f-f b/mats/patch-interpret-3-f-f-f index 237cfe3ed0..49483e6c77 100644 --- a/mats/patch-interpret-3-f-f-f +++ b/mats/patch-interpret-3-f-f-f @@ -1,5 +1,5 @@ -*** errors-compile-3-f-f-f 2017-10-13 11:55:48.000000000 -0400 ---- errors-interpret-3-f-f-f 2017-10-13 12:40:16.000000000 -0400 +*** errors-compile-3-f-f-f 2017-10-27 10:26:56.000000000 -0400 +--- errors-interpret-3-f-f-f 2017-10-27 11:09:29.000000000 -0400 *************** *** 1,3 **** --- 1,9 ---- diff --git a/mats/patch-interpret-3-f-t-f b/mats/patch-interpret-3-f-t-f index 59c87694ea..997bcdfd5b 100644 --- a/mats/patch-interpret-3-f-t-f +++ b/mats/patch-interpret-3-f-t-f @@ -1,5 +1,5 @@ -*** errors-compile-3-f-t-f 2017-10-13 12:03:19.000000000 -0400 ---- errors-interpret-3-f-t-f 2017-10-13 12:27:55.000000000 -0400 +*** errors-compile-3-f-t-f 2017-10-27 10:34:20.000000000 -0400 +--- errors-interpret-3-f-t-f 2017-10-27 10:57:54.000000000 -0400 *************** *** 1,3 **** --- 1,9 ---- diff --git a/mats/patch-interpret-3-t-f-f b/mats/patch-interpret-3-t-f-f index 1228b18ece..4006907cb5 100644 --- a/mats/patch-interpret-3-t-f-f +++ b/mats/patch-interpret-3-t-f-f @@ -1,5 +1,5 @@ -*** errors-compile-3-t-f-f 2017-06-06 16:40:11.147295805 -0400 ---- errors-interpret-3-t-f-f 2017-06-06 17:42:49.478165307 -0400 +*** errors-compile-3-t-f-f 2017-10-27 02:41:58.000000000 -0400 +--- errors-interpret-3-t-f-f 2017-10-27 03:47:08.000000000 -0400 *************** *** 1,3 **** --- 1,9 ---- diff --git a/mats/patch-interpret-3-t-t-f b/mats/patch-interpret-3-t-t-f index 73908ea66e..9d40a7819a 100644 --- a/mats/patch-interpret-3-t-t-f +++ b/mats/patch-interpret-3-t-t-f @@ -1,5 +1,5 @@ -*** errors-compile-3-t-t-f 2017-06-06 16:44:51.178581446 -0400 ---- errors-interpret-3-t-t-f 2017-06-06 17:48:13.954153204 -0400 +*** errors-compile-3-t-t-f 2017-10-27 02:36:19.000000000 -0400 +--- errors-interpret-3-t-t-f 2017-10-27 03:52:31.000000000 -0400 *************** *** 1,3 **** --- 1,9 ---- diff --git a/s/compile.ss b/s/compile.ss index e712f1b949..e012607bf3 100644 --- a/s/compile.ss +++ b/s/compile.ss @@ -1403,20 +1403,20 @@ [else (sorry! who "unexpected Lexpand record ~s" ir)])) (unless (environment? env-spec) ($oops who "~s is not an environment" env-spec)) ((parameterize ([$target-machine (constant machine-type-name)] [$sfd #f]) - (let* ([x1 (expand-Lexpand (expand x0 env-spec #t))] + (let* ([x1 (expand-Lexpand ($pass-time 'expand (lambda () (expand x0 env-spec #t))))] [waste ($uncprep x1 #t)] ; populate preinfo sexpr fields [waste (when (and (expand-output) (not ($noexpand? x0))) (pretty-print ($uncprep x1) (expand-output)))] - [x2 ($cpvalid x1)] + [x2 ($pass-time 'cpvalid (lambda () ($cpvalid x1)))] [x2a (let ([cpletrec-ran? #f]) (let ([x ((run-cp0) (lambda (x) (set! cpletrec-ran? #t) - (let ([x ($cp0 x)]) - ($cpletrec x))) + (let ([x ($pass-time 'cp0 (lambda () ($cp0 x)))]) + ($pass-time 'cpletrec (lambda () ($cpletrec x))))) x2)]) - (if cpletrec-ran? x ($cpletrec x))))] - [x2b ($cpcheck x2a)]) + (if cpletrec-ran? x ($pass-time 'cpletrec (lambda () ($cpletrec x))))))] + [x2b ($pass-time 'cpcheck (lambda () ($cpcheck x2a)))]) (when (and (expand/optimize-output) (not ($noexpand? x0))) (pretty-print ($uncprep x2b) (expand/optimize-output))) (if (and (compile-interpret-simple) diff --git a/s/cp0.ss b/s/cp0.ss index e8f6145d8e..df254dacfa 100644 --- a/s/cp0.ss +++ b/s/cp0.ss @@ -2594,6 +2594,20 @@ (define-inline-carry-op fx-/carry -) (define-inline-carry-op fx*/carry (lambda (x y z) (+ (* x y) z)))) + (define-inline 3 fxdiv-and-mod + [(x y) + (and likely-to-be-compiled? + (cp0-constant? (result-exp (value-visit-operand! y))) + (cp0 + (let ([tx (cp0-make-temp #t)] [ty (cp0-make-temp #t)]) + (let ([refx (build-ref tx)] [refy (build-ref ty)]) + (build-lambda (list tx ty) + (build-primcall 3 'values + (list + (build-primcall 3 'fxdiv (list refx refy)) + (build-primcall 3 'fxmod (list refx refy))))))) + ctxt empty-env sc wd name moi))]) + (define-inline 2 $top-level-value [(x) (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! x)) diff --git a/s/cpnanopass.ss b/s/cpnanopass.ss index 9f23cb2e72..8d50bb2944 100644 --- a/s/cpnanopass.ss +++ b/s/cpnanopass.ss @@ -250,12 +250,17 @@ (bytevector-u16-native-ref bv n)) count)))))))) - (module (empty-tree tree-extract tree-for-each tree-fold-left tree-bit-set? tree-bit-set tree-bit-unset tree-bit-count tree-same? tree-merge) + (module (empty-tree full-tree tree-extract tree-for-each tree-fold-left tree-bit-set? tree-bit-set tree-bit-unset tree-bit-count tree-same? tree-merge) ; tree -> fixnum | (tree-node tree tree) ; 0 represents any tree or subtree with no bits set, and a tree or subtree ; with no bits set is always 0 (define empty-tree 0) + ; any tree or subtree with all bits set + (define full-tree #t) + + (define (full-fixnum size) (fxsrl (most-positive-fixnum) (fx- (fx- (fixnum-width) 1) size))) + (define compute-split (lambda (size) (fxsrl size 1) @@ -269,7 +274,7 @@ (meta-cond [(fx= (optimize-level) 3) - (module (make-tree-node tree-node-left tree-node-right) + (module (make-tree-node tree-node? tree-node-left tree-node-right) (define make-tree-node cons) (define tree-node? pair?) (define tree-node-left car) @@ -298,55 +303,87 @@ (define tree-extract ; assumes empty-tree is 0 (lambda (st size v) (let extract ([st st] [size size] [offset 0] [x* '()]) - (if (fixnum? st) + (cond + [(fixnum? st) (do ([st st (fxsrl st 1)] [offset offset (fx+ offset 1)] [x* x* (if (fxodd? st) (cons (vector-ref v offset) x*) x*)]) - ((fx= st 0) x*)) + ((fx= st 0) x*))] + [(eq? st full-tree) + (do ([size size (fx- size 1)] + [offset offset (fx+ offset 1)] + [x* x* (cons (vector-ref v offset) x*)]) + ((fx= size 0) x*))] + [else (let ([split (compute-split size)]) (extract (tree-node-right st) (fx- size split) (fx+ offset split) - (extract (tree-node-left st) split offset x*))))))) + (extract (tree-node-left st) split offset x*)))])))) (define tree-for-each ; assumes empty-tree is 0 - (lambda (st size action) - (let f ([st st] [size size] [offset 0]) - (if (fixnum? st) - (do ([st st (fxsrl st 1)] [offset offset (fx+ offset 1)]) - ((fx= st 0)) - (when (fxodd? st) (action offset))) - (let ([split (compute-split size)]) - (f (tree-node-left st) split offset) - (f (tree-node-right st) (fx- size split) (fx+ offset split))))))) + (lambda (st size start end action) + (let f ([st st] [size size] [start start] [end end] [offset 0]) + (cond + [(fixnum? st) + (unless (eq? st empty-tree) + (do ([st (fxbit-field st start end) (fxsrl st 1)] [offset (fx+ offset start) (fx+ offset 1)]) + ((fx= st 0)) + (when (fxodd? st) (action offset))))] + [(eq? st full-tree) + (do ([start start (fx+ start 1)] [offset offset (fx+ offset 1)]) + ((fx= start end)) + (action offset))] + [else + (let ([split (compute-split size)]) + (when (fx< start split) + (f (tree-node-left st) split start (fxmin end split) offset)) + (when (fx> end split) + (f (tree-node-right st) (fx- size split) (fxmax (fx- start split) 0) (fx- end split) (fx+ offset split))))])))) (define tree-fold-left ; assumes empty-tree is 0 (lambda (proc size init st) (let f ([st st] [size size] [offset 0] [init init]) - (if (fixnum? st) + (cond + [(fixnum? st) (do ([st st (fxsrl st 1)] [offset offset (fx+ offset 1)] [init init (if (fxodd? st) (proc init offset) init)]) - ((fx= st 0) init)) + ((fx= st 0) init))] + [(eq? st full-tree) + (do ([size size (fx- size 1)] + [offset offset (fx+ offset 1)] + [init init (proc init offset)]) + ((fx= size 0) init))] + [else (let ([split (compute-split size)]) (f (tree-node-left st) split offset - (f (tree-node-right st) (fx- size split) (fx+ offset split) init))))))) + (f (tree-node-right st) (fx- size split) (fx+ offset split) init)))])))) (define tree-bit-set? ; assumes empty-tree is 0 (lambda (st size bit) (let loop ([st st] [size size] [bit bit]) - (if (fixnum? st) + (cond + [(fixnum? st) (and (not (eqv? st empty-tree)) ; fxlogbit? is unnecessarily general, so roll our own - (fxlogtest st (fxsll 1 bit))) + (fxlogtest st (fxsll 1 bit)))] + [(eq? st full-tree) #t] + [else (let ([split (compute-split size)]) (if (fx< bit split) (loop (tree-node-left st) split bit) - (loop (tree-node-right st) (fx- size split) (fx- bit split)))))))) + (loop (tree-node-right st) (fx- size split) (fx- bit split))))])))) (define tree-bit-set ; assumes empty-tree is 0 (lambda (st size bit) ; set bit in tree. result is eq? to tr if result is same as tr. - (if (fx< size (fixnum-width)) - (fxlogbit1 bit st) + (cond + [(eq? st full-tree) st] + [(fx< size (fixnum-width)) + (let ([st (fxlogbit1 bit st)]) + (if (fx= st (full-fixnum size)) + full-tree + st))] + [else (let ([split (compute-split size)]) (if (eqv? st empty-tree) (if (fx< bit split) @@ -357,19 +394,32 @@ (let ([new-lst (tree-bit-set lst split bit)]) (if (eq? new-lst lst) st - (make-tree-node new-lst rst))) + (if (and (eq? new-lst full-tree) (eq? rst full-tree)) + full-tree + (make-tree-node new-lst rst)))) (let ([new-rst (tree-bit-set rst (fx- size split) (fx- bit split))]) (if (eq? new-rst rst) st - (make-tree-node lst new-rst)))))))))) + (if (and (eq? lst full-tree) (eq? new-rst full-tree)) + full-tree + (make-tree-node lst new-rst))))))))]))) (define tree-bit-unset ; assumes empty-tree is 0 (lambda (st size bit) ; reset bit in tree. result is eq? to tr if result is same as tr. - (if (fixnum? st) - (if (eqv? st empty-tree) - empty-tree - (fxlogbit0 bit st)) + (cond + [(fixnum? st) + (if (eqv? st empty-tree) + empty-tree + (fxlogbit0 bit st))] + [(eq? st full-tree) + (if (fx< size (fixnum-width)) + (fxlogbit0 bit (full-fixnum size)) + (let ([split (compute-split size)]) + (if (fx< bit split) + (make-tree-node (tree-bit-unset full-tree split bit) full-tree) + (make-tree-node full-tree (tree-bit-unset full-tree (fx- size split) (fx- bit split))))))] + [else (let ([split (compute-split size)] [lst (tree-node-left st)] [rst (tree-node-right st)]) (if (fx< bit split) (let ([new-lst (tree-bit-unset lst split bit)]) @@ -383,40 +433,52 @@ st (if (and (eq? lst empty-tree) (eq? new-rst empty-tree)) empty-tree - (make-tree-node lst new-rst))))))))) + (make-tree-node lst new-rst))))))]))) (define tree-bit-count ; assumes empty-tree is 0 - (lambda (st) - (if (fixnum? st) - (fxbit-count st) - (fx+ (tree-bit-count (tree-node-left st)) - (tree-bit-count (tree-node-right st)))))) + (lambda (st size) + (cond + [(fixnum? st) (fxbit-count st)] + [(eq? st full-tree) size] + [else + (let ([split (compute-split size)]) + (fx+ + (tree-bit-count (tree-node-left st) split) + (tree-bit-count (tree-node-right st) (fx- size split))))]))) (define tree-same? ; assumes empty-tree is 0 (lambda (st1 st2) - (or (eq? st1 st2) ; assuming fixnums are eq-comparable - (and (not (fixnum? st1)) - (not (fixnum? st2)) + (or (eq? st1 st2) ; assuming fixnums and full trees are eq-comparable + (and (tree-node? st1) + (tree-node? st2) (tree-same? (tree-node-left st1) (tree-node-left st2)) (tree-same? (tree-node-right st1) (tree-node-right st2)))))) - (define tree-merge ; assumes empty-tree is 0 + (define tree-merge ; merge tr1 and tr2. result is eq? to tr1 if result is same as tr1. - (lambda (st1 st2) + (lambda (st1 st2 size) (cond - [(eq? st1 st2) st1] - [(fixnum? st1) (if (fixnum? st2) (fxlogor st1 st2) st2)] - [(eq? st2 empty-tree) st1] + [(or (eq? st1 st2) (eq? st2 empty-tree)) st1] + [(eq? st1 empty-tree) st2] + [(or (eq? st1 full-tree) (eq? st2 full-tree)) full-tree] + [(fixnum? st1) + (safe-assert (fixnum? st2)) + (let ([st (fxlogor st1 st2)]) + (if (fx= st (full-fixnum size)) + full-tree + st))] [else (let ([lst1 (tree-node-left st1)] [rst1 (tree-node-right st1)] [lst2 (tree-node-left st2)] [rst2 (tree-node-right st2)]) - (let ([l (tree-merge lst1 lst2)] [r (tree-merge rst1 rst2)]) + (let ([split (compute-split size)]) + (let ([l (tree-merge lst1 lst2 split)] [r (tree-merge rst1 rst2 (fx- size split))]) (cond [(and (eq? l lst1) (eq? r rst1)) st1] [(and (eq? l lst2) (eq? r rst2)) st2] - [else (make-tree-node l r)])))])))) + [(and (eq? l full-tree) (eq? r full-tree)) full-tree] + [else (make-tree-node l r)]))))])))) (define-syntax tc-disp (lambda (x) @@ -546,12 +608,6 @@ [else (with-syntax ([%mref (datum->syntax x '%mref)]) #'(%mref ,%sfp 0))]))) - ; asm-return-registsrs, L-doargerr, etc., encapsulate registers and must be - ; created fresh for each compiler run, so we just define makers here. - (define make-asm-return-registers - (lambda () - ; these registers are preserved by each hand-coded library routine that returns to its caller - (reg-cons* %cp %ret (append arg-registers extra-registers)))) (define make-Ldoargerr (lambda () (make-libspec-label 'doargerr (lookup-libspec doargerr) @@ -9960,7 +10016,6 @@ (import (only asm-module asm-foreign-call asm-foreign-callable asm-enter)) (define newframe-info-for-mventry-point) (define Lcall-error (make-Lcall-error)) - (define asm-return-registers (make-asm-return-registers)) (define dcl*) (define local*) (define max-fv) @@ -10298,6 +10353,7 @@ (safe-assert cnfv) (%seq (remove-frame ,newframe-info) + (restore-local-saves ,newframe-info) (set! ,(ref-reg %cp) ,cnfv) ,(build-shift-args newframe-info)))) ,(build-consumer-call tc (in-context Triv (ref-reg %cp)) #f)) @@ -10305,9 +10361,10 @@ `(seq ,(build-nontail-call info mdcl t0 t1* tc* '() mrvl #t (lambda (newframe-info) - `(seq - (remove-frame ,newframe-info) - ,(build-shift-args newframe-info)))) + (%seq + (remove-frame ,newframe-info) + (restore-local-saves ,newframe-info) + ,(build-shift-args newframe-info)))) ,(build-consumer-call tc #f #f)))))))) (define build-mv-return (lambda (t*) @@ -11154,20 +11211,22 @@ (handle-do-rest fixed-args frame-args-offset #f))] ; TODO: get internal error when , is missing from ,l [(mventry-point (,x* ...) ,l) - (let f ([x* x*]) - (if (null? x*) - (%seq - (remove-frame ,newframe-info-for-mventry-point) - (goto ,l)) - (let ([x (car x*)]) - (if (uvar-referenced? x) - `(seq (set! ,x ,(uvar-location x)) ,(f (cdr x*))) - (f (cdr x*))))))] + (%seq + (remove-frame ,newframe-info-for-mventry-point) + ,(let f ([x* x*]) + (if (null? x*) + (%seq + (restore-local-saves ,newframe-info-for-mventry-point) + (goto ,l)) + (let ([x (car x*)]) + (if (uvar-referenced? x) + `(seq (set! ,x ,(uvar-location x)) ,(f (cdr x*))) + (f (cdr x*)))))))] [(mvcall ,info ,mdcl ,t0? ,t1* ... (,t* ...)) (let ([mrvl (make-local-label 'mrvl)]) (build-nontail-call info mdcl t0? t1* t* '() mrvl #f (lambda (newframe-info) - `(seq (label ,mrvl) (remove-frame ,newframe-info)))))] + (%seq (label ,mrvl) (remove-frame ,newframe-info) (restore-local-saves ,newframe-info)))))] [(mvset ,info (,mdcl ,t0? ,t1* ...) (,t* ...) ((,x** ...) ...) ,ebody) (let* ([frame-x** (map (lambda (x*) (set-formal-registers! x*)) x**)] [nfv** (map (lambda (x*) (map (lambda (x) @@ -11184,7 +11243,7 @@ [(set! ,[lvalue] (mvcall ,info ,mdcl ,t0? ,t1* ... (,t* ...))) (build-nontail-call info mdcl t0? t1* t* '() #f #f (lambda (newframe-info) - `(seq (set! ,lvalue ,%ac0) (remove-frame ,newframe-info))))] + (%seq (remove-frame ,newframe-info) (set! ,lvalue ,%ac0) (restore-local-saves ,newframe-info))))] [(foreign-call ,info ,[t0] ,[t1*] ...) (build-foreign-call info t0 t1* #f #t)] [(set! ,[lvalue] (foreign-call ,info ,[t0] ,[t1*] ...)) @@ -11247,7 +11306,6 @@ (definitions (import (only asm-module asm-enter)) (define Ldoargerr (make-Ldoargerr)) - (define asm-return-registers (make-asm-return-registers)) (define-$type-check (L13.5 Pred)) (define make-info (lambda (name interface*) @@ -12045,9 +12103,10 @@ (jump ,%ref-ret (,%ac0))))] [(bytevector=?) (let ([bv1 (make-tmp 'bv1)] [bv2 (make-tmp 'bv2)] [idx (make-tmp 'idx)] [len2 (make-tmp 'len2)]) + (define (argcnt->max-fv n) (max (- n (length arg-registers)) 0)) (let ([Ltop (make-local-label 'Ltop)] [Ltrue (make-local-label 'Ltrue)] [Lfail (make-local-label 'Lfail)]) (define iptr-bytes (in-context Triv (%constant ptr-bytes))) - `(lambda ,(make-info "bytevector=?" '(2)) 0 (,bv1 ,bv2 ,idx ,len2) + `(lambda ,(make-info "bytevector=?" '(2)) ,(argcnt->max-fv 2) (,bv1 ,bv2 ,idx ,len2) ,(%seq (set! ,bv1 ,(make-arg-opnd 1)) (set! ,bv2 ,(make-arg-opnd 2)) @@ -12465,6 +12524,9 @@ [(remove-frame ,info) (add-instr! target (with-output-language (L15a Effect) `(remove-frame ,(make-live-info) ,info))) (values target block*)] + [(restore-local-saves ,info) + (add-instr! target (with-output-language (L15a Effect) `(restore-local-saves ,(make-live-info) ,info))) + (values target block*)] [(return-point ,info ,rpl ,mrvl (,cnfv* ...)) (add-instr! target (with-output-language (L15a Effect) `(return-point ,info ,rpl ,mrvl (,cnfv* ...)))) (block-return-point! target #t) @@ -13350,11 +13412,11 @@ [(if-block? b) ; must follow same order as loop above so we find the same loop headers (let ([lhs (f (if-block-true b))]) - (tree-merge lhs (f (if-block-false b))))] + (tree-merge lhs (f (if-block-false b)) tree-size))] [(newframe-block? b) ; must follow same order as loop above so we find the same loop headers - (fold-left (lambda (lhs b) (tree-merge lhs (f b))) - (let ([lhs (f (newframe-block-next b))]) (tree-merge lhs (f (newframe-block-rp b)))) + (fold-left (lambda (lhs b) (tree-merge lhs (f b) tree-size)) + (let ([lhs (f (newframe-block-next b))]) (tree-merge lhs (f (newframe-block-rp b)) tree-size)) (newframe-block-rp* b))] [else (sorry! who "unrecognized block ~s" b)]))]) (unless (or (block-loop-header? b) (eqv? (block-loop-headers b) empty-tree)) @@ -13891,13 +13953,14 @@ (define-threaded unspillable*) (define-threaded max-fv) (define-threaded max-fs@call) + (define-threaded poison-cset) (define no-live* empty-tree) (define union-live ; union live1 and live2. result is eq? to live1 if result is same as live1. - (lambda (live1 live2) - (tree-merge live1 live2))) + (lambda (live1 live2 live-size) + (tree-merge live1 live2 live-size))) (define same-live? (lambda (live1 live2) @@ -13933,15 +13996,22 @@ new) live*))))) - (module (make-cset conflict-bit-set! conflict-bit-unset! conflict-bit-set? conflict-bit-count cset-merge! cset-copy cset-for-each extract-conflicts) + (module (make-empty-cset make-full-cset cset-full? conflict-bit-set! conflict-bit-unset! conflict-bit-set? conflict-bit-count cset-merge! cset-copy cset-for-each extract-conflicts) (define-record-type cset (nongenerative) - (fields size (mutable tree)) - (protocol - (lambda (n) - (case-lambda - [(size) (n size empty-tree)] - [(size tree) (n size tree)])))) + (fields size (mutable tree))) + + (define make-empty-cset + (lambda (size) + (make-cset size empty-tree))) + + (define make-full-cset + (lambda (size) + (make-cset size full-tree))) + + (define cset-full? + (lambda (cset) + (eq? (cset-tree cset) full-tree))) (define conflict-bit-set! (lambda (cset offset) @@ -13959,11 +14029,11 @@ (define conflict-bit-count (lambda (cset) - (tree-bit-count (cset-tree cset)))) + (tree-bit-count (cset-tree cset) (cset-size cset)))) (define cset-merge! (lambda (cset1 cset2) - (cset-tree-set! cset1 (tree-merge (cset-tree cset1) (cset-tree cset2))))) + (cset-tree-set! cset1 (tree-merge (cset-tree cset1) (cset-tree cset2) (cset-size cset1))))) (define cset-copy (lambda (cset) @@ -13971,7 +14041,7 @@ (define cset-for-each (lambda (cset proc) - (tree-for-each (cset-tree cset) (cset-size cset) proc))) + (tree-for-each (cset-tree cset) (cset-size cset) 0 (cset-size cset) proc))) (define extract-conflicts (lambda (cset v) @@ -14061,6 +14131,7 @@ (fold-left add-var out (info-kill*-live*-live* info)) out)))] [(remove-frame ,live-info ,info) (live-info-live-set! live-info out) out] + [(restore-local-saves ,live-info ,info) (live-info-live-set! live-info out) out] [(shift-arg ,live-info ,reg ,imm ,info) (live-info-live-set! live-info out) out] [(overflow-check ,live-info) (live-info-live-set! live-info out) out] [(overflood-check ,live-info) (live-info-live-set! live-info out) out] @@ -14121,7 +14192,7 @@ (force-live-in! true-block) (force-live-in! false-block) (block-seen! block #f) - (let ([out (union-live (block-live-in true-block) (block-live-in false-block))]) + (let ([out (union-live (block-live-in true-block) (block-live-in false-block) live-size)]) (when (different? out (if-block-live-out block)) (if-block-live-out-set! block out) (propagate-live! block out))))] @@ -14164,9 +14235,10 @@ (newframe-block-live-call-set! block call) call)))]) (let ([out (union-live - (fold-left (lambda (live b) (union-live (block-live-in b) live)) + (fold-left (lambda (live b) (union-live (block-live-in b) live live-size)) (block-live-in next-block) rp-block*) - (fold-left add-var call (info-newframe-cnfv* newframe-info)))]) + (fold-left add-var call (info-newframe-cnfv* newframe-info)) + live-size)]) (when (different? out (newframe-block-live-out block)) (newframe-block-live-out-set! block out) (propagate-live! block out))))))] @@ -14234,23 +14306,55 @@ (define $add-move! (lambda (x1 x2 weight) (when (uvar? x1) - (uvar-move*-set! x1 - (call-with-values - (lambda () - (let f ([move* (uvar-move* x1)]) - (if (null? move*) - (values (cons x2 weight) move*) - (let ([move (car move*)] [move* (cdr move*)]) - (if (eq? (car move) x2) - (values (cons (car move) (fx+ (cdr move) weight)) move*) - (let-values ([(move2 move*) (f move*)]) - (if (fx> (cdr move2) (cdr move)) - (values move2 (cons move move*)) - (values move (cons move2 move*))))))))) - cons))))) + (when (or (not (uvar-poison? x1)) (fv? x2)) + (uvar-move*-set! x1 + (call-with-values + (lambda () + (let f ([move* (uvar-move* x1)]) + (if (null? move*) + (values (cons x2 weight) move*) + (let ([move (car move*)] [move* (cdr move*)]) + (if (eq? (car move) x2) + (values (cons (car move) (fx+ (cdr move) weight)) move*) + (let-values ([(move2 move*) (f move*)]) + (if (fx> (cdr move2) (cdr move)) + (values move2 (cons move move*)) + (values move (cons move2 move*))))))))) + cons)))))) + + (define-who identify-poison! + (lambda (kspillable varvec live-size block*) + (define kpoison 0) + (define increment-live-counts! + (lambda (live) + (tree-for-each live live-size 0 kspillable + (lambda (offset) + (let ([x (vector-ref varvec offset)]) + (let ([range (fx+ (uvar-live-count x) 1)]) + (when (fx= range 2) + (uvar-poison! x #t) + (set! kpoison (fx+ kpoison 1))) + (uvar-live-count-set! x range))))))) + (define Effect + (lambda (live* e) + (nanopass-case (L15a Effect) e + [(set! ,live-info ,x ,rhs) + (guard (uvar? x)) + (if (live-info-useless live-info) + live* + (cons (live-info-live live-info) live*))] + [else live*]))) + (let ([vlive (list->vector (fold-left (lambda (live* block) (fold-left Effect live* (block-effect* block))) '() block*))]) + (let ([nvlive (vector-length vlive)]) + (let refine ([skip 64] [stride 64]) + (do ([i (fx- skip 1) (fx+ i stride)]) + ((fx>= i nvlive)) + (increment-live-counts! (vector-ref vlive i))) + (unless (or (fx= stride 16) (< (* (fx- kspillable kpoison) (fx* stride 2)) 1000000)) + (refine (fxsrl skip 1) skip))))))) (define-who do-spillable-conflict! - (lambda (kspillable varvec live-size block*) + (lambda (kspillable kfv varvec live-size block*) (define remove-var (make-remove-var live-size)) (define add-move! (lambda (x1 x2) @@ -14259,19 +14363,42 @@ ($add-move! x2 x1 2)))) (define add-conflict! (lambda (x out) + ; invariants: + ; all poison spillables explicitly point to all spillables + ; all non-poison spillables implicitly point to all poison spillables via poison-cset (let ([x-offset (var-index x)]) (when x-offset - (tree-for-each out live-size - (let ([cset (var-spillable-conflict* x)]) - (if (fx< x-offset kspillable) - (lambda (y-offset) - ; x is a spillable. if y is also a spillable, point x at y - (when (fx< y-offset kspillable) (conflict-bit-set! cset y-offset)) - ; point y at the spillable x regardless - (conflict-bit-set! (var-spillable-conflict* (vector-ref varvec y-offset)) x-offset)) - (lambda (y-offset) - ; x is fixed. if y is a spillable, point x at y - (when (fx< y-offset kspillable) (conflict-bit-set! cset y-offset)))))))))) + (if (and (fx< x-offset kspillable) (uvar-poison? x)) + (tree-for-each out live-size kspillable (fx+ kspillable kfv) + (lambda (y-offset) + ; frame y -> poison spillable x + (conflict-bit-set! (var-spillable-conflict* (vector-ref varvec y-offset)) x-offset))) + (let ([cset (var-spillable-conflict* x)]) + (if (fx< x-offset kspillable) + (begin + (tree-for-each out live-size 0 kspillable + (lambda (y-offset) + (let ([y (vector-ref varvec y-offset)]) + (unless (uvar-poison? y) + ; non-poison spillable x -> non-poison spillable y + (conflict-bit-set! cset y-offset) + ; and vice versa + (conflict-bit-set! (var-spillable-conflict* y) x-offset))))) + (tree-for-each out live-size kspillable live-size + (lambda (y-offset) + (let ([y (vector-ref varvec y-offset)]) + ; frame or register y -> non-poison spillable x + (conflict-bit-set! (var-spillable-conflict* y) x-offset))))) + (if (fx< x-offset (fx+ kspillable kfv)) + (tree-for-each out live-size 0 kspillable + (lambda (y-offset) + ; frame x -> poison or non-poison spillable y + (conflict-bit-set! cset y-offset))) + (tree-for-each out live-size 0 kspillable + (lambda (y-offset) + (unless (uvar-poison? (vector-ref varvec y-offset)) + ; register x -> non-poison spillable y + (conflict-bit-set! cset y-offset)))))))))))) (define Rhs (lambda (rhs live) (nanopass-case (L15a Rhs) rhs @@ -14301,7 +14428,19 @@ (for-each (lambda (x) (add-conflict! x live)) (info-kill*-kill* info))) (cons e new-effect*)] [else (cons e new-effect*)]))) - (vector-for-each (lambda (x) (var-spillable-conflict*-set! x (make-cset kspillable))) varvec) + (do ([i 0 (fx+ i 1)]) + ((fx= i kspillable)) + (let ([x (vector-ref varvec i)]) + (if (uvar-poison? x) + (begin + (conflict-bit-set! poison-cset i) + ; leaving each poison spillable in conflict with itself, but this shouldn't matter + ; since we never ask for the degree of a poison spillable + (var-spillable-conflict*-set! x (make-full-cset kspillable))) + (var-spillable-conflict*-set! x (make-empty-cset kspillable))))) + (do ([i kspillable (fx+ i 1)]) + ((fx= i live-size)) + (var-spillable-conflict*-set! (vector-ref varvec i) (make-empty-cset kspillable))) (for-each (lambda (block) (block-effect*-set! block @@ -14334,13 +14473,11 @@ ; tempting to set to cset2 rather than (cset-copy cset2), but this would not be ; correct for local saves, which need their unaltered sets for later, and copying ; is cheap anyway. - (var-spillable-conflict*-set! fv (cset-copy cset2)))))) + (var-spillable-conflict*-set! fv (cset-copy cset2)))) + (unless (uvar-poison? spill) (cset-merge! (var-spillable-conflict* fv) poison-cset)))) (define assign-frame! - (lambda () - (define spillable? - (lambda (x) - (and (uvar? x) (not (uvar-unspillable? x))))) + (lambda (spill*) (define sort-spill* ; NB: sorts based on likelihood of successfully assigning move-related vars to the same location ; NB: probably should sort based on value of assigning move-related vars to the same location, @@ -14360,15 +14497,12 @@ w))]) ((null? move*) (cons x w)))) spill*))))) - (define conflict? - (lambda (x fv-offset) - (conflict-fv? x (get-fv fv-offset)))) - (define conflict-fv? - (lambda (x fv) - (let ([cset (var-spillable-conflict* fv)]) - (and cset (conflict-bit-set? cset (var-index x)))))) (define find-move-related-home (lambda (x0 succ fail) + (define conflict-fv? + (lambda (x fv) + (let ([cset (var-spillable-conflict* fv)]) + (and cset (conflict-bit-set? cset (var-index x)))))) (let f ([x x0] [work* '()] [clear-seen! void]) (if (uvar-seen? x) (if (null? work*) (begin (clear-seen!) (fail)) (f (car work*) (cdr work*) clear-seen!)) @@ -14394,31 +14528,36 @@ (loop move* (cons var work*)))) (loop move* work*))))))))))) (define find-home! - (lambda (spill max-fv) + (lambda (spill max-fv first-open) (define return - (lambda (home max-fv) + (lambda (home max-fv first-open) (uvar-location-set! spill home) (update-conflict! home spill) - max-fv)) + (values max-fv first-open))) (find-move-related-home spill - (lambda (home) (return home max-fv)) + (lambda (home) (return home max-fv first-open)) (lambda () - (let f ([fv-offset 1]) - (if (conflict? spill fv-offset) - (f (fx+ fv-offset 1)) - (return (get-fv fv-offset) (fxmax fv-offset max-fv)))))))) + (let f ([first-open first-open]) + (let* ([fv (get-fv first-open)] [cset (var-spillable-conflict* fv)]) + (if (and cset (cset-full? cset)) + (f (fx+ first-open 1)) + (let ([spill-offset (var-index spill)]) + (let f ([fv-offset first-open] [fv fv] [cset cset]) + (if (and cset (conflict-bit-set? cset spill-offset)) + (let* ([fv-offset (fx+ fv-offset 1)] [fv (get-fv fv-offset)] [cset (var-spillable-conflict* fv)]) + (f fv-offset fv cset)) + (return fv (fxmax fv-offset max-fv) first-open))))))))))) (define find-homes! - (lambda (spill* max-fv) - (let f ([spill* spill*] [max-fv max-fv]) - (if (null? spill*) - max-fv - (let ([spill (car spill*)]) - (f (cdr spill*) (find-home! spill max-fv))))))) + (lambda (spill* max-fv first-open) + (if (null? spill*) + max-fv + (let-values ([(max-fv first-open) (find-home! (car spill*) max-fv first-open)]) + (find-homes! (cdr spill*) max-fv first-open))))) ; NOTE: call-live uvars should be sorted so that those that are call-live with few other ; variables are earlier in the list (and more likely to get a low frame location); ; additionally if they are live across many frames they should be prioritized over those ; live across only a few (only when setup-nfv?) - (set! max-fv (find-homes! (sort-spill* (filter uvar-spilled? spillable*)) max-fv)))) + (set! max-fv (find-homes! (sort-spill* spill*) max-fv 1)))) (define-pass assign-new-frame! : (L15a Dummy) (ir lambda-info live-size varvec block*) -> (L15b Dummy) () (definitions @@ -14457,25 +14596,41 @@ (for-each (lambda (nfv*) (set-offsets! nfv* arg-base)) nfv**) base) (loop (fx+ base 1)))))))) + (define build-mask + (lambda (index*) + (define bucket-width (if (fx> (fixnum-width) 32) 32 16)) + (let* ([nbits (fx+ (fold-left (lambda (m index) (fxmax m index)) -1 index*) 1)] + [nbuckets (fxdiv (fx+ nbits (fx- bucket-width 1)) bucket-width)] + [buckets (make-fxvector nbuckets 0)]) + (for-each + (lambda (index) + (let-values ([(i j) (fxdiv-and-mod index bucket-width)]) + (fxvector-set! buckets i (fxlogbit1 j (fxvector-ref buckets i))))) + index*) + (let f ([base 0] [len nbuckets]) + (if (fx< len 2) + (if (fx= len 0) + 0 + (fxvector-ref buckets base)) + (let ([half (fxsrl len 1)]) + (logor + (bitwise-arithmetic-shift-left (f (fx+ base half) (fx- len half)) (fx* half bucket-width)) + (f base half)))))))) (define build-live-pointer-mask (lambda (live*) - (define set-lpm-bit - (lambda (fv lpm) - (let ([i (fv-offset fv)]) - (if (fx= i 0) - lpm - (logbit1 (fx- i 1) lpm))))) - (fold-left - (lambda (lpm live) - (cond - [(fv? live) - ; assuming call-live frame variables are ptrs for the time being - ; they should all be products of tail-frame optimization on (ptr) arguments - (set-lpm-bit live lpm)] - [(and live (eq? (uvar-type live) 'ptr)) - (set-lpm-bit (uvar-location live) lpm)] - [else lpm])) - 0 live*))) + (build-mask + (fold-left + (lambda (index* live) + (define (cons-fv fv index*) + (let ([offset (fv-offset fv)]) + (if (fx= offset 0) ; no bit for fv0 + index* + (cons (fx- offset 1) index*)))) + (cond + [(fv? live) (cons-fv live index*)] + [(eq? (uvar-type live) 'ptr) (cons-fv (uvar-location live) index*)] + [else index*])) + '() live*)))) (define (process-info-newframe! info) (unless (info-newframe-frame-words info) (let ([call-live* (info-newframe-call-live* info)]) @@ -14491,17 +14646,18 @@ (cond [(and call-live* (info-lambda-ctci lambda-info)) => (lambda (ctci) - (let ([mask (fold-left - (lambda (mask x) - (cond - [(and (uvar? x) (uvar-iii x)) => - (lambda (index) - (let ([name.offset (vector-ref (ctci-live ctci) index)]) - (unless (logbit? (fx- (cdr name.offset) 1) lpm) - (sorry! who "bit ~s not set for ~s in ~s" (cdr name.offset) (car name.offset) lpm))) - (logor (ash 1 index) mask))] - [else mask])) - 0 call-live*)]) + (let ([mask (build-mask + (fold-left + (lambda (i* x) + (cond + [(and (uvar? x) (uvar-iii x)) => + (lambda (index) + (safe-assert + (let ([name.offset (vector-ref (ctci-live ctci) index)]) + (logbit? (fx- (cdr name.offset) 1) lpm))) + (cons index i*))] + [else i*])) + '() call-live*))]) (when (or src sexpr (not (eqv? mask 0))) (ctci-rpi*-set! ctci (cons (make-ctrpi rpl src sexpr mask) (ctci-rpi* ctci))))))])))) (Pred : Pred (ir) -> Pred ()) @@ -14519,14 +14675,18 @@ (cons `(rp-header ,mrvl ,(fx* (info-newframe-frame-words info) (constant ptr-bytes)) ,lpm) new-effect*)))] [(remove-frame ,live-info ,info) (process-info-newframe! info) + (with-output-language (L15b Effect) + (let ([live (live-info-live live-info)]) + (cons* + `(fp-offset ,live-info ,(fx- (fx* (info-newframe-frame-words info) (constant ptr-bytes)))) + `(overflood-check ,(make-live-info live)) + new-effect*)))] + [(restore-local-saves ,live-info ,info) (with-output-language (L15b Effect) (let ([live (live-info-live live-info)]) (let loop ([x* (filter (lambda (x) (live? live live-size x)) (info-newframe-local-save* info))] [live live] - [new-effect* (cons* - `(fp-offset ,live-info ,(fx- (fx* (info-newframe-frame-words info) (constant ptr-bytes)))) - `(overflood-check ,(make-live-info live)) - new-effect*)]) + [new-effect* new-effect*]) (if (null? x*) new-effect* (let* ([x (car x*)] [live (remove-var live x)]) @@ -14556,7 +14716,7 @@ (lambda (x) ; NB: experiment with different comparisions. might want ref weight ; NB: to be at least more than save weight to relieve register pressure. - (when (and (uvar-spilled? x) (fx>= (uvar-ref-weight x) (uvar-save-weight x))) + (when (and (uvar-spilled? x) (not (uvar-poison? x)) (fx>= (uvar-ref-weight x) (uvar-save-weight x))) (uvar-local-save! x #t))) spillable*) (for-each @@ -14587,7 +14747,8 @@ (lambda (x) (when (uvar-local-save? x) (uvar-location-set! x #f) - (uvar-spilled! x #f))) + (uvar-spilled! x #f) + (uvar-save-weight-set! x 0))) spillable*) `(dummy)))) @@ -14986,7 +15147,7 @@ (define add-us->s-conflicts! (lambda (x out) ; x is an unspillable (let ([x-offset (var-index x)] [cset (var-spillable-conflict* x)]) - (tree-for-each out live-size + (tree-for-each out live-size 0 live-size (lambda (y-offset) (let* ([y (vector-ref varvec y-offset)] [y-cset (var-unspillable-conflict* y)]) (when y-cset @@ -15074,8 +15235,8 @@ [(move-related ,x1 ,x2) (add-move-hint! x1 x2) unspillable*] [(overflow-check ,p ,e* ...) (Effect* (reverse e*) '()) (Pred p)] [else unspillable*]))))) - (for-each (lambda (x) (var-spillable-conflict*-set! x (make-cset kspillable))) unspillable*) - (let ([f (lambda (x) (var-unspillable-conflict*-set! x (make-cset kunspillable)))]) + (for-each (lambda (x) (var-spillable-conflict*-set! x (make-empty-cset kspillable))) unspillable*) + (let ([f (lambda (x) (var-unspillable-conflict*-set! x (make-empty-cset kunspillable)))]) (vector-for-each f regvec) (for-each f spillable*) (vector-for-each f unvarvec)) @@ -15091,75 +15252,73 @@ block*))) (define-who assign-registers! - (lambda (lambda-info) + (lambda (lambda-info varvec unvarvec) + (define k (vector-length regvec)) + (define uvar-weight + (lambda (x) + (fx- (uvar-ref-weight x) (uvar-save-weight x)))) ; could also be calculated when the conflict set is built, which would be more ; efficient for low-degree variables - (define compute-degree! - ; NB: it would probably be faster to go through the registers and - ; NB: increment the degrees for each spillable and unspillable with - ; NB: which it conflicts, rather than go through each register for - ; NB: each uvar as we are currently doing - (lambda (x) - (let ([x-offset (var-index x)]) - (let loop ([n (vector-length regvec)] [degree 0]) - (if (fx= n 0) - (uvar-degree-set! x - (fx+ degree - ; spills have been trimmed from the var-spillable-conflict* sets - (conflict-bit-count (var-spillable-conflict* x)) - (conflict-bit-count (var-unspillable-conflict* x)))) - (let ([n (fx- n 1)]) - (let ([reg (vector-ref regvec n)]) - (let ([cset (if (uvar-unspillable? x) (var-unspillable-conflict* reg) (var-spillable-conflict* reg))]) - (if (and cset (conflict-bit-set? cset x-offset)) - (loop n (fx+ degree 1)) - (loop n degree)))))))))) - (define conflict? - (lambda (reg x) - (let ([cset (if (uvar-unspillable? x) (var-unspillable-conflict* reg) (var-spillable-conflict* reg))]) - (and cset (conflict-bit-set? cset (var-index x)))))) - (define update-conflict! - (lambda (reg x) - (let ([cset1 (var-spillable-conflict* reg)] - [cset2 (var-spillable-conflict* x)]) - (if cset1 - (cset-merge! cset1 cset2) - ; we copy spillable conflicts to avoid ruining a uvar's cset for the next iteration of the big loop - (var-spillable-conflict*-set! reg (cset-copy cset2)))) - (let ([cset1 (var-unspillable-conflict* reg)] - [cset2 (var-unspillable-conflict* x)]) - (if cset1 - (cset-merge! cset1 cset2) - ; NB: do we need to copy unspillable conflicts? we recreate them each time through the big loop - (var-unspillable-conflict*-set! reg (cset-copy cset2)))))) - (define find-move-related-home - (lambda (x0 succ fail) - (let f ([x x0] [work* '()] [clear-seen! void]) - (if (uvar-seen? x) - (if (null? work*) (begin (clear-seen!) (fail)) (f (car work*) (cdr work*) clear-seen!)) - (let ([clear-seen! (lambda () (uvar-seen! x #f) (clear-seen!))]) - (uvar-seen! x #t) - (let loop ([move* (uvar-move* x)] [work* work*]) - (if (null? move*) - (if (null? work*) (begin (clear-seen!) (fail)) (f (car work*) (cdr work*) clear-seen!)) - (let ([var (caar move*)] [move* (cdr move*)]) - (define try-reg - (lambda (reg) - (if (conflict? reg x0) - (loop move* work*) - (begin (clear-seen!) (succ reg))))) - (if (reg? var) - (try-reg var) - (if (uvar? var) - (let ([reg (uvar-location var)]) - (if (reg? reg) - (try-reg reg) - (loop move* (cons var work*)))) - (loop move* work*))))))))))) + (define compute-degrees! + (lambda (x*) + ; account for uvar -> uvar conflicts + (for-each + (lambda (x) + (uvar-degree-set! x + (fx+ + ; spills have been trimmed from the var-spillable-conflict* sets + (conflict-bit-count (var-spillable-conflict* x)) + (conflict-bit-count (var-unspillable-conflict* x))))) + x*) + ; account for reg -> uvar conflicts + (vector-for-each + (lambda (reg) + (cset-for-each (var-spillable-conflict* reg) + (lambda (x-offset) + (let ([x (vector-ref varvec x-offset)]) + (unless (uvar-location x) + (uvar-degree-set! x (fx+ (uvar-degree x) 1)))))) + (cset-for-each (var-unspillable-conflict* reg) + (lambda (x-offset) + (let ([x (vector-ref unvarvec x-offset)]) + (uvar-degree-set! x (fx+ (uvar-degree x) 1)))))) + regvec))) (define-who find-home! (lambda (x) + (define conflict? + (lambda (reg x) + (let ([cset (if (uvar-unspillable? x) (var-unspillable-conflict* reg) (var-spillable-conflict* reg))]) + (conflict-bit-set? cset (var-index x))))) + (define find-move-related-home + (lambda (x0 succ fail) + (let f ([x x0] [work* '()] [clear-seen! void]) + (if (uvar-seen? x) + (if (null? work*) (begin (clear-seen!) (fail)) (f (car work*) (cdr work*) clear-seen!)) + (let ([clear-seen! (lambda () (uvar-seen! x #f) (clear-seen!))]) + (uvar-seen! x #t) + (let loop ([move* (uvar-move* x)] [work* work*]) + (if (null? move*) + (if (null? work*) (begin (clear-seen!) (fail)) (f (car work*) (cdr work*) clear-seen!)) + (let ([var (caar move*)] [move* (cdr move*)]) + (define try-reg + (lambda (reg) + (if (conflict? reg x0) + (loop move* work*) + (begin (clear-seen!) (succ reg))))) + (if (reg? var) + (try-reg var) + (if (uvar? var) + (let ([reg (uvar-location var)]) + (if (reg? reg) + (try-reg reg) + (loop move* (cons var work*)))) + (loop move* work*))))))))))) (define set-home! (lambda (home) + (define update-conflict! + (lambda (reg x) + (cset-merge! (var-spillable-conflict* reg) (var-spillable-conflict* x)) + (cset-merge! (var-unspillable-conflict* reg) (var-unspillable-conflict* x)))) (uvar-location-set! x home) (update-conflict! home x))) (find-move-related-home x @@ -15173,99 +15332,73 @@ (sorry! who "spilled unspillable ~s" x))] [(conflict? (vector-ref regvec offset) x) (f (fx- offset 1))] [else (set-home! (vector-ref regvec offset))])))))) - (define k (vector-length regvec)) - (define low-degree? (lambda (x) (fx< (uvar-degree x) k))) - (define update-spillable-degree! - (lambda (x offset) - (when (conflict-bit-set? (var-spillable-conflict* x) offset) - (uvar-degree-set! x (fx- (uvar-degree x) 1))))) - (define update-unspillable-degree! - (lambda (x offset) - (when (conflict-bit-set? (var-unspillable-conflict* x) offset) - (uvar-degree-set! x (fx- (uvar-degree x) 1))))) - (define remove-victim! - (lambda (victim x*) - (let ([offset (var-index victim)]) - (if (uvar-unspillable? victim) - (for-each (lambda (x) (update-unspillable-degree! x offset)) x*) - (for-each (lambda (x) (update-spillable-degree! x offset)) x*))))) - (define sort-victims - ; NB: sorts based on likelihood of successfully assigning move-related vars to the same register - ; NB: probably should sort based on value of assigning move-related vars to the same register, - ; NB: i.e., taking into account the ref-weight or uvar-weight - (lambda (victim*) - (map car - (list-sort - (lambda (x y) (fx> (cdr x) (cdr y))) - (map (lambda (x) - (define relevant? - (lambda (x) - (or (reg? x) (and (uvar? x) (not (uvar-spilled? x)))))) - (do ([move* (uvar-move* x) (cdr move*)] - [w 0 (let ([move (car move*)]) - (if (relevant? (car move)) - (fx+ w (cdr move)) - w))]) - ((null? move*) (cons x w)))) - victim*))))) - (define uvar-weight - (lambda (x) - (fx- (uvar-ref-weight x) (uvar-save-weight x)))) - (define pick-potential-spill - ; x* is already sorted by ref weight, so this effectively picks uvar with - ; the highest degree among those with the lowest ref weight - (lambda (x*) - (let ([x (let f ([x* (cdr x*)] [max-degree (uvar-degree (car x*))] [max-x (car x*)]) - (if (null? x*) - max-x - (let ([x (car x*)] [x* (cdr x*)]) - (if (or (uvar-unspillable? x) (fx> (uvar-weight x) (uvar-weight max-x))) - max-x - (let ([degree (uvar-degree x)]) - (if (fx> degree max-degree) - (f x* degree x) - (f x* max-degree max-x)))))))]) - (values x (remq x x*))))) (define pick-victims (lambda (x*) + (define low-degree? (lambda (x) (fx< (uvar-degree x) k))) + (define pick-potential-spill + ; x* is already sorted by weight, so this effectively picks uvar with + ; the highest degree among those with the lowest weight + (lambda (x*) + (let ([x (let f ([x* (cdr x*)] [max-degree (uvar-degree (car x*))] [max-x (car x*)]) + (if (null? x*) + max-x + (let ([x (car x*)] [x* (cdr x*)]) + (if (or (uvar-unspillable? x) (fx> (uvar-weight x) (uvar-weight max-x))) + max-x + (let ([degree (uvar-degree x)]) + (if (fx> degree max-degree) + (f x* degree x) + (f x* max-degree max-x)))))))]) + (values x (remq x x*))))) + (define remove-victim! + (lambda (victim) + (cset-for-each (var-spillable-conflict* victim) + (lambda (offset) + (let ([x (vector-ref varvec offset)]) + (uvar-degree-set! x (fx- (uvar-degree x) 1))))) + (cset-for-each (var-unspillable-conflict* victim) + (lambda (offset) + (let ([x (vector-ref unvarvec offset)]) + (uvar-degree-set! x (fx- (uvar-degree x) 1))))))) + (define sort-victims + ; NB: sorts based on likelihood of successfully assigning move-related vars to the same register + ; NB: probably should sort based on value of assigning move-related vars to the same register, + ; NB: i.e., taking into account the ref-weight + (lambda (victim*) + (map car + (list-sort + (lambda (x y) (fx> (cdr x) (cdr y))) + (map (lambda (x) + (define relevant? + (lambda (x) + (or (reg? x) (and (uvar? x) (not (uvar-spilled? x)))))) + (do ([move* (uvar-move* x) (cdr move*)] + [w 0 (let ([move (car move*)]) + (if (relevant? (car move)) + (fx+ w (cdr move)) + w))]) + ((null? move*) (cons x w)))) + victim*))))) (let-values ([(victim* keeper*) (partition low-degree? x*)]) (if (null? victim*) (let-values ([(victim keeper*) (pick-potential-spill x*)]) ; note: victim can be an unspillable if x* contains only precolored unspillables - (remove-victim! victim keeper*) + (remove-victim! victim) (values (list victim) keeper*)) (begin (unless (null? keeper*) ; tried creating a mask from victim*, logand with bv for each x, count the bits, ; and subtract from x's uvar-degree-set!. code in chaff. didn't help at this point. ; perhaps if fxbit-count were implemented better it would - (for-each (lambda (victim) (remove-victim! victim keeper*)) victim*)) + (for-each remove-victim! victim*)) (values (sort-victims victim*) keeper*)))))) - (define find-homes! - (lambda (x*) - (for-each compute-degree! x*) - (let f ([x* x*]) - (unless (null? x*) - (let-values ([(victim* x*) (pick-victims x*)]) - (f x*) - (for-each find-home! victim*)))))) - (let (#;[time0 (cpu-time)]) - ; NB: consider taking into account the size of the live region, perhaps - ; NB: estimated by the length of the uvar's name :). - (let ([x* (append (sort (lambda (x y) (fx< (uvar-weight x) (uvar-weight y))) spillable*) unspillable*)]) - (find-homes! x*) - #;(let ([ms (- (cpu-time) time0)]) - (define lengths - (lambda (x*) - (let f ([x* x*] [ulen 0] [slen 0]) - (cond - [(null? x*) (values ulen slen)] - [(uvar-unspillable? (car x*)) (f (cdr x*) (fx+ ulen 1) slen)] - [else (f (cdr x*) ulen (fx+ slen 1))])))) - (let-values ([(ulen slen) (lengths x*)]) - (when (> (fx+ ulen slen) 1000) - (printf "ran assign-registers for ~a (~d unspillables, ~d spillables, ~d spilled) in ~d ms\n" - (info-lambda-name lambda-info) ulen slen (- (length spillable*) slen) ms)))))))) + (let ([x* (append (sort (lambda (x y) (fx< (uvar-weight x) (uvar-weight y))) spillable*) unspillable*)]) + (compute-degrees! x*) + (let f ([x* x*]) + (unless (null? x*) + (let-values ([(victim* x*) (pick-victims x*)]) + (f x*) + (for-each find-home! victim*))))))) (define everybody-home? (lambda () @@ -15322,7 +15455,8 @@ (let ([v (f (fx+ i 1) (cdr spillable*))]) (uvar-iii-set! spillable i) (vector-set! v i (cons (unannotate source) (fv-offset (uvar-location spillable)))) - v)]) + v)] + [else (f i (cdr spillable*))]) (let ([v (f (fx+ i 1) (cdr spillable*))]) (uvar-iii-set! spillable i) (vector-set! v i (cons (unannotate source) (fv-offset (uvar-location spillable)))) @@ -15474,8 +15608,8 @@ [(_ ?unparser pass-name ?arg ...) #'(xpass pass-name (RAprinter ?unparser) (list ?arg ...))])))) (safe-assert (andmap (lambda (x) (eq? (uvar-location x) #f)) local*)) - (fluid-let ([spillable* local*] [unspillable* '()] [max-fv max-fv0] [max-fs@call 0]) - (let ([kfv (fx+ max-fv 1)] [kreg (vector-length regvec)] [kspillable (length spillable*)]) + (let ([kspillable (length local*)] [kfv (fx+ max-fv0 1)] [kreg (vector-length regvec)]) + (fluid-let ([spillable* local*] [unspillable* '()] [max-fv max-fv0] [max-fs@call 0] [poison-cset (make-empty-cset kspillable)]) (let* ([live-size (fx+ kfv kreg kspillable)] [varvec (make-vector live-size)]) ; set up var indices & varvec mapping from indices to vars (fold-left (lambda (i x) (var-index-set! x i) (vector-set! varvec i x) (fx+ i 1)) 0 spillable*) @@ -15489,10 +15623,12 @@ ; rerun intra-block live analysis and record (fv v reg v spillable) x spillable conflicts (RApass unparse-L15a record-call-live! block* varvec) ;; NB: we could just use (vector-length varvec) to get live-size - (RApass unparse-L15a do-spillable-conflict! kspillable varvec live-size block*) + (when (fx> kspillable 1000) ; NB: parameter? + (RApass unparse-L15a identify-poison! kspillable varvec live-size block*)) + (RApass unparse-L15a do-spillable-conflict! kspillable kfv varvec live-size block*) #;(show-conflicts (info-lambda-name info) varvec '#()) ; find frame homes for call-live variables; adds new fv x spillable conflicts - (RApass unparse-L15a assign-frame!) + (RApass unparse-L15a assign-frame! (filter uvar-spilled? spillable*)) #;(show-homes) (RApass unparse-L15a record-inspector-information! info) ; determine frame sizes at nontail-call sites and assign homes to new-frame variables @@ -15500,19 +15636,25 @@ (let ([dummy (RApass unparse-L15b assign-new-frame! (with-output-language (L15a Dummy) `(dummy)) info live-size varvec block*)]) ; record fp offset on entry to each block (RApass unparse-L15b record-fp-offsets! entry-block*) + ; assign frame homes to poison variables + (let ([spill* (filter (lambda (x) (and (not (uvar-location x)) (uvar-poison? x))) spillable*)]) + (unless (null? spill*) + (for-each (lambda (x) (uvar-spilled! x #t)) spill*) + (RApass unparse-L15b assign-frame! spill*))) ; on entry to loop, have assigned call-live and new-frame variables to frame homes, determined frame sizes, and computed block-entry fp offsets - (let ([v (vector-map var-spillable-conflict* regvec)] + (let ([saved-reg-csets (vector-map (lambda (reg) (cset-copy (var-spillable-conflict* reg))) regvec)] [bcache* (map cache-block-info block*)]) (let loop () (for-each (lambda (spill) ; remove each spill from each other spillable's spillable conflict set - (let ([spill-index (var-index spill)] [cset (var-spillable-conflict* spill)]) - (cset-for-each cset - (lambda (i) - (let ([x (vector-ref varvec i)]) - (unless (uvar-location x) - (conflict-bit-unset! (var-spillable-conflict* x) spill-index)))))) + (unless (uvar-poison? spill) + (let ([spill-index (var-index spill)]) + (cset-for-each (var-spillable-conflict* spill) + (lambda (i) + (let ([x (vector-ref varvec i)]) + (unless (uvar-location x) + (conflict-bit-unset! (var-spillable-conflict* x) spill-index))))))) ; release the spill's conflict* set (var-spillable-conflict*-set! spill #f)) (filter uvar-location spillable*)) @@ -15530,7 +15672,7 @@ ; rerun intra-block live analysis and record (reg v spillable v unspillable) x unspillable conflicts (RApass unparse-L15d do-unspillable-conflict! kfv kspillable varvec live-size kunspillable unvarvec block*) #;(show-conflicts (info-lambda-name info) varvec unvarvec) - (RApass unparse-L15d assign-registers! info) + (RApass unparse-L15d assign-registers! info varvec unvarvec) ; release the unspillable conflict sets (for-each (lambda (x) (var-unspillable-conflict*-set! x #f)) spillable*) (vector-for-each (lambda (x) (var-unspillable-conflict*-set! x #f)) regvec) @@ -15552,11 +15694,11 @@ `(lambda ,info (,entry-block* ...) (,block* ...)))) (begin (for-each restore-block-info! block* bcache*) - (vector-for-each var-spillable-conflict*-set! regvec v) + (vector-for-each var-spillable-conflict*-set! regvec saved-reg-csets) (for-each (lambda (x) (uvar-location-set! x #f)) spillable*) (for-each uvar-move*-set! spillable* saved-move*) (set! unspillable* '()) - (RApass unparse-L15b assign-frame!) + (RApass unparse-L15b assign-frame! (filter uvar-spilled? spillable*)) (loop)))))))))))))))]))) ; NB: commonize with earlier diff --git a/s/np-languages.ss b/s/np-languages.ss index ef81f8cdc2..c6e9de1cb9 100644 --- a/s/np-languages.ss +++ b/s/np-languages.ss @@ -21,12 +21,13 @@ uvar-referenced? uvar-referenced! uvar-assigned? uvar-assigned! uvar-was-closure-ref? uvar-was-closure-ref! uvar-unspillable? uvar-spilled? uvar-spilled! uvar-local-save? uvar-local-save! - uvar-seen? uvar-seen! uvar-loop? uvar-loop! + uvar-seen? uvar-seen! uvar-loop? uvar-loop! uvar-poison? uvar-poison! uvar-in-prefix? uvar-in-prefix! uvar-location uvar-location-set! uvar-move* uvar-move*-set! uvar-conflict* uvar-ref-weight uvar-ref-weight-set! uvar-save-weight uvar-save-weight-set! + uvar-live-count uvar-live-count-set! uvar fv-offset var-spillable-conflict* var-spillable-conflict*-set! @@ -161,6 +162,7 @@ (loop #b00001000000) (in-prefix #b00010000000) (local-save #b00100000000) + (poison #b01000000000) ) (define-record-type (uvar $make-uvar uvar?) @@ -178,13 +180,14 @@ (mutable iii) ; inspector info index (mutable ref-weight) ; must be a fixnum! (mutable save-weight) ; must be a fixnum! + (mutable live-count) ; must be a fixnum! ) (nongenerative) (sealed #t) (protocol (lambda (pargs->new) (lambda (name source type conflict* flags) - ((pargs->new) name source type conflict* flags #f #f '() #f #f 0 0))))) + ((pargs->new) name source type conflict* flags #f #f '() #f #f 0 0 0))))) (define prelex->uvar (lambda (x) ($make-uvar (prelex-name x) (prelex-source x) 'ptr '() @@ -829,6 +832,7 @@ (return-point info rpl mrvl (cnfv* ...)) (rp-header mrvl fs lpm) (remove-frame info) + (restore-local-saves info) (shift-arg reg imm info) (set! lvalue rhs) (inline info effect-prim t* ...) => (inline info effect-prim t* ...) @@ -949,6 +953,7 @@ (return-point info rpl mrvl (cnfv* ...)) (rp-header mrvl fs lpm) (remove-frame live-info info) + (restore-local-saves live-info info) (shift-arg live-info reg imm info) (set! live-info lvalue rhs) (inline live-info info effect-prim t* ...) @@ -967,6 +972,7 @@ (label (l)))) (Effect (e) (- (remove-frame live-info info) + (restore-local-saves live-info info) (return-point info rpl mrvl (cnfv* ...)) (shift-arg live-info reg imm info) (check-live live-info reg* ...)) diff --git a/s/primdata.ss b/s/primdata.ss index 5bd0c3411b..60163efd8d 100644 --- a/s/primdata.ss +++ b/s/primdata.ss @@ -55,7 +55,7 @@ ((r6rs: fx*) [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op partial-folder]) ; restricted to 2 arguments ((r6rs: fx+) [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op partial-folder]) ; restricted to 2 arguments ((r6rs: fx-) [sig [(fixnum) (fixnum fixnum) -> (fixnum)]] [flags arith-op partial-folder]) ; restricted to 1 or 2 arguments - (fxdiv-and-mod [sig [(fixnum fixnum) -> (fixnum fixnum)]] [flags discard]) + (fxdiv-and-mod [sig [(fixnum fixnum) -> (fixnum fixnum)]] [flags discard cp03]) (fxdiv [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op cp02]) (fxmod [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op cp02]) (fxdiv0-and-mod0 [sig [(fixnum fixnum) -> (fixnum fixnum)]] [flags discard]) From 0d236d959cf0f2a56b2bf7850733fcc347c37694 Mon Sep 17 00:00:00 2001 From: dyb Date: Fri, 27 Oct 2017 23:21:28 -0400 Subject: [PATCH 2/9] fixed LOG entry original commit: 328cb00845cc52fa89c3e558bfdab2fcf8f3bee1 --- LOG | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/LOG b/LOG index 081015fad8..0641fc5f9a 100644 --- a/LOG +++ b/LOG @@ -660,7 +660,7 @@ hand-coded bytevector=? handler. cpnanopass.ss - reduced live-pointer and inspector free-variable mask computation - overhead for live masks. + overhead cpnanopass.ss - moved regvec cset copies to driver so they aren't copied each time a uvar is assigned to a register. removed checks for From 9b6b6d32eed729c39d7a18c5498c6d85b9481ba6 Mon Sep 17 00:00:00 2001 From: dyb Date: Sun, 29 Oct 2017 17:48:43 -0400 Subject: [PATCH 3/9] attempt to stabilize timing tests let-values source-caching test and ephemeron gc test while resensitizing the former 8.ms, 4.ms various formatting and comment corrections workarea, s/Mf-base, bytevector.ss, cpnanopass.ss, date.ss, 5_6.ms, examples.ms original commit: 19e2505fc6477fce2d1d0e61187bd504b58ea994 --- LOG | 7 ++ mats/4.ms | 46 +++++++----- mats/5_6.ms | 2 +- mats/8.ms | 20 +++-- mats/examples.ms | 1 - s/Mf-base | 4 +- s/bytevector.ss | 46 ++++++------ s/cpnanopass.ss | 186 +++++++++++++++++++++++------------------------ s/date.ss | 10 +-- workarea | 7 +- 10 files changed, 172 insertions(+), 157 deletions(-) diff --git a/LOG b/LOG index 0641fc5f9a..1a470c5233 100644 --- a/LOG +++ b/LOG @@ -720,3 +720,10 @@ 8.ms - updated allx, bullyx patches patch* +- attempt to stabilize timing tests let-values source-caching + test and ephemeron gc test while resensitizing the former + 8.ms, 4.ms +- various formatting and comment corrections + workarea, + s/Mf-base, bytevector.ss, cpnanopass.ss, date.ss, + 5_6.ms, examples.ms diff --git a/mats/4.ms b/mats/4.ms index 3d2990385c..2f1a5cdb33 100644 --- a/mats/4.ms +++ b/mats/4.ms @@ -3496,7 +3496,7 @@ ;; ---------------------------------------- ;; Stress test to check that the GC doesn't suffer from quadratic ;; behavior - (begin + (let () (define (wrapper v) (list 1 2 3 4 5 v)) ;; Create a chain of ephemerons where we have all @@ -3532,21 +3532,24 @@ ;; off the end of the discover-ephemerons-one-at-a-time ;; chain, which is the most complex case for avoiding ;; quadratic GC times - (define-values (key es) (mk n (gensym) '())) - (define-values (root holds) (mk* n key es)) - - (define start (current-time)) - (collect (collect-maximum-generation)) - (let ([delta (time-difference (current-time) start)]) - ;; Sanity check on ephemerons - (for-each (lambda (e) - (when (eq? #!bwp (ephemeron-key e)) - (error 'check "oops"))) - es) - ;; Keep `root` and `holds` live: - (keep-alive (cons root holds)) - ;; Return duration: - delta)) + (parameterize ([collect-request-handler void] [collect-maximum-generation (max (collect-maximum-generation) 2)]) + (collect 2) + (let*-values ([(key es) (mk n (gensym) '())] + [(root holds) (mk* n key es)]) + (let ([start (current-time)]) + (collect 0 1) + (collect 1 2) + (collect 2 2) + (let ([delta (time-difference (current-time) start)]) + ;; Sanity check on ephemerons + (for-each (lambda (e) + (when (eq? #!bwp (ephemeron-key e)) + (error 'check "oops"))) + es) + ;; Keep `root` and `holds` live: + (keep-alive (cons root holds)) + ;; Return duration: + delta))))) (define N 10000) @@ -3558,11 +3561,14 @@ (define dummy2 (set! dummy #f)) (define t2 (measure-time N keep-alive)) (define (duration->inexact t) (+ (* (time-second t) 1e9) - (time-nanosecond t))) + (inexact (time-nanosecond t)))) (set! dummy #f) - (or (< (/ (duration->inexact t1) (duration->inexact t2)) 20) - (and (positive? tries) - (loop (sub1 tries)))))) + (let ([t1 (duration->inexact t1)] [t2 (duration->inexact t2)]) + (or (< (/ t1 t2) 20) + (begin + (printf "t1 = ~s, t2 = ~s, t1/t2 = ~s\n" t1 t2 (/ t1 t2)) + (and (positive? tries) + (loop (sub1 tries)))))))) ;; ---------------------------------------- ;; Check interaction of mutation and generations diff --git a/mats/5_6.ms b/mats/5_6.ms index b613b04c2d..86fc47e01b 100644 --- a/mats/5_6.ms +++ b/mats/5_6.ms @@ -1,4 +1,4 @@ -;;; 5-5.ms +;;; 5_6.ms ;;; Copyright 1984-2017 Cisco Systems, Inc. ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); diff --git a/mats/8.ms b/mats/8.ms index d7d9b97914..20efa5c3d8 100644 --- a/mats/8.ms +++ b/mats/8.ms @@ -11093,18 +11093,22 @@ (lambda () (pretty-print (make-expr n))) 'truncate) - (let ([start (current-time)]) - (load "testfile.ss" expand) - (let ([delta (time-difference (current-time) start)]) - (+ (time-second delta) - (* 1e-9 (time-nanosecond delta)))))) + (collect) + (parameterize ([collect-request-handler void]) + (let ([start (current-time)]) + (load "testfile.ss" expand) + (let ([delta (time-difference (current-time) start)]) + (+ (* #e1e9 (time-second delta)) + (time-nanosecond delta)))))) (let loop ([tries 3]) (when (zero? tries) (error 'source-cache-test "loading lots of `let-values` forms seems to take too long")) - (or (> (* 30 (time-expr 100)) - (time-expr 1000)) - (loop (sub1 tries))))) + (let ([t1000 (time-expr 1000)] [t10000 (time-expr 10000)]) + (or (> (* 20 t1000) t10000) + (begin + (printf "t1000 = ~s, t10000 = ~s, t10000 / t1000 = ~s\n" t1000 t10000 (inexact (/ t10000 t1000))) + (loop (sub1 tries))))))) (begin (define sfd-to-cache diff --git a/mats/examples.ms b/mats/examples.ms index c13b6d3bb2..7235e4bf7e 100644 --- a/mats/examples.ms +++ b/mats/examples.ms @@ -1,4 +1,3 @@ -;; examples .ms ;;; examples.ms ;;; Copyright 1984-2017 Cisco Systems, Inc. ;;; diff --git a/s/Mf-base b/s/Mf-base index f7ef72f042..ba99af842c 100644 --- a/s/Mf-base +++ b/s/Mf-base @@ -61,7 +61,7 @@ pdhtml = f # gac determines whether cost-center allocation counts are generated: f for false, t for true gac = f -# gac determines whether cost-center instruction counts are generated: f for false, t for true +# gic determines whether cost-center instruction counts are generated: f for false, t for true gic = f # pps determines whether pass timings are printed @@ -151,7 +151,7 @@ allsrc =\ # doit uses a different Scheme process to compile each target doit: ${PetiteBoot} ${SchemeBoot} ${Cheader} ${Cequates} -# doit uses a single Scheme process to compile all targets. this is typically +# all uses a single Scheme process to compile all targets. this is typically # faster when most of the targets need to be recompiled. all: bootall ${Cheader} ${Cequates} diff --git a/s/bytevector.ss b/s/bytevector.ss index c45c46e013..24b6bf388c 100644 --- a/s/bytevector.ss +++ b/s/bytevector.ss @@ -1,13 +1,13 @@ "bytevector.ss" ;;; bytevector.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. @@ -320,7 +320,7 @@ (little-ref v i))] [else #`(little-ref v i)])] [else (unrecognized-endianness who eness)])))]))) - + (define $bytevector-s16-ref (bytevector-*-ref s 16)) (define $bytevector-u16-ref (bytevector-*-ref u 16)) (define $bytevector-s24-ref (bytevector-*-ref s 24)) @@ -769,7 +769,7 @@ ($oops who "index ~s + count ~s is beyond the end of ~s" i2 k v2)) ; whew! (#3%bytevector-copy! v1 i1 v2 i2 k)))) - + (set-who! bytevector->immutable-bytevector (lambda (v) (cond @@ -829,11 +829,11 @@ (lambda (v i eness) ($bytevector-u24-ref v i eness who))) - (set-who! bytevector-s32-ref + (set-who! bytevector-s32-ref (lambda (v i eness) ($bytevector-s32-ref v i eness who))) - (set-who! bytevector-u32-ref + (set-who! bytevector-u32-ref (lambda (v i eness) ($bytevector-u32-ref v i eness who))) @@ -861,67 +861,67 @@ (lambda (v i eness) ($bytevector-u56-ref v i eness who))) - (set-who! bytevector-s64-ref + (set-who! bytevector-s64-ref (lambda (v i eness) ($bytevector-s64-ref v i eness who))) - (set-who! bytevector-u64-ref + (set-who! bytevector-u64-ref (lambda (v i eness) ($bytevector-u64-ref v i eness who))) - (set-who! bytevector-s16-set! + (set-who! bytevector-s16-set! (lambda (v i k eness) ($bytevector-s16-set! v i k eness who))) - (set-who! bytevector-u16-set! + (set-who! bytevector-u16-set! (lambda (v i k eness) ($bytevector-u16-set! v i k eness who))) - (set-who! bytevector-s24-set! + (set-who! bytevector-s24-set! (lambda (v i k eness) ($bytevector-s24-set! v i k eness who))) - (set-who! bytevector-u24-set! + (set-who! bytevector-u24-set! (lambda (v i k eness) ($bytevector-u24-set! v i k eness who))) - (set-who! bytevector-s32-set! + (set-who! bytevector-s32-set! (lambda (v i k eness) ($bytevector-s32-set! v i k eness who))) - (set-who! bytevector-u32-set! + (set-who! bytevector-u32-set! (lambda (v i k eness) ($bytevector-u32-set! v i k eness who))) - (set-who! bytevector-s40-set! + (set-who! bytevector-s40-set! (lambda (v i k eness) ($bytevector-s40-set! v i k eness who))) - (set-who! bytevector-u40-set! + (set-who! bytevector-u40-set! (lambda (v i k eness) ($bytevector-u40-set! v i k eness who))) - (set-who! bytevector-s48-set! + (set-who! bytevector-s48-set! (lambda (v i k eness) ($bytevector-s48-set! v i k eness who))) - (set-who! bytevector-u48-set! + (set-who! bytevector-u48-set! (lambda (v i k eness) ($bytevector-u48-set! v i k eness who))) - (set-who! bytevector-s56-set! + (set-who! bytevector-s56-set! (lambda (v i k eness) ($bytevector-s56-set! v i k eness who))) - (set-who! bytevector-u56-set! + (set-who! bytevector-u56-set! (lambda (v i k eness) ($bytevector-u56-set! v i k eness who))) - (set-who! bytevector-s64-set! + (set-who! bytevector-s64-set! (lambda (v i k eness) ($bytevector-s64-set! v i k eness who))) - (set-who! bytevector-u64-set! + (set-who! bytevector-u64-set! (lambda (v i k eness) ($bytevector-u64-set! v i k eness who))) diff --git a/s/cpnanopass.ss b/s/cpnanopass.ss index 8d50bb2944..8287a0b002 100644 --- a/s/cpnanopass.ss +++ b/s/cpnanopass.ss @@ -1,13 +1,13 @@ "cpnanopass.ss" ;;; cpnanopass.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. @@ -824,7 +824,7 @@ (define-record-type info-kill*-live* (nongenerative) (parent info-kill*) (fields live*) - (protocol + (protocol (lambda (new) (case-lambda [(kill* live*) @@ -838,7 +838,7 @@ (fields libspec save-ra?) (protocol (lambda (new) - (case-lambda + (case-lambda [(kill* libspec save-ra? live*) ((new kill* live*) libspec save-ra?)] [(kill* libspec save-ra?) @@ -914,7 +914,7 @@ (export dorest-intrinsic-max) (define (list-xtail ls n) (if (or (null? ls) (fx= n 0)) - ls + ls (list-xtail (cdr ls) (fx1- n)))) (define dorest-intrinsics (let () @@ -1190,7 +1190,7 @@ ; can't use a guard, since body isn't bound in guard. (if (eq? body x1) (build-seq* profile1* - (build-seq* profile2* + (build-seq* profile2* `(letrec ([,x1 ,le*]) (call ,info1 ,x1 ,e* ...)))) `(call ,info1 ,(build-seq* profile1* (Expr e)) ,e* ...))] [else @@ -1933,9 +1933,9 @@ (define add-raw-counters (lambda (free** e) (if (track-dynamic-closure-counts) - (let f ([x** free**] [alloc 0] [raw 0]) + (let f ([x** free**] [alloc 0] [raw 0]) (if (null? x**) - (add-counter '#{raw-create-count bhowt6w0coxl0s2y-2} (length free**) + (add-counter '#{raw-create-count bhowt6w0coxl0s2y-2} (length free**) (add-counter '#{raw-alloc-count bhowt6w0coxl0s2y-3} alloc (add-counter '#{raw-ref-count bhowt6w0coxl0s2y-1} raw e))) (let ([x* (car x**)]) @@ -1998,7 +1998,7 @@ (+ (static-closure-info-wk-borrowed-count ci) 1))] [(closure) (static-closure-info-nwk-closure-count-set! ci - (+ (static-closure-info-nwk-closure-count ci) 1)) + (+ (static-closure-info-nwk-closure-count ci) 1)) (static-closure-info-nwk-closure-free-var-count-set! ci (+ (static-closure-info-nwk-closure-free-var-count ci) (length (closure-free* c))))] @@ -2112,7 +2112,7 @@ `(let ([,(closure-name c) ,(%primcall #f #f cons ,(map build-free-ref (closure-free* c)) ...)]) ,body)] [(vector) - `(let ([,(closure-name c) ,(%primcall #f #f vector ,(map build-free-ref (closure-free* c)) ...)]) + `(let ([,(closure-name c) ,(%primcall #f #f vector ,(map build-free-ref (closure-free* c)) ...)]) ,body)] [else (safe-assert (eq? (closure-type c) 'closure)) @@ -2156,7 +2156,7 @@ (with-frob-location (cadr free*) (add-ref-counter (%mref ,mcp ,(constant pair-cdr-disp))) (Expr body index bank)))] [else - (safe-assert (memq type '(vector closure))) + (safe-assert (memq type '(vector closure))) (let f ([free* free*] [i (if (eq? type 'vector) (constant vector-data-disp) (constant closure-data-disp))]) (if (null? free*) (Expr body index bank) @@ -2244,7 +2244,7 @@ ; find closures w/free variables (non-constant closures) and propagate (when (ormap (lambda (c) (not (null? (closure-free* c)))) c*) (for-each - (lambda (c) + (lambda (c) (closure-free*-set! c (append (closure-sibling* c) (closure-free* c)))) c*)) @@ -2416,7 +2416,7 @@ (let-values ([(out ...) (proc (car ls1) (car ls2) ...)] [(out* ...) (f (cdr ls1) (cdr ls2) ...)]) (values (cons out out*) ...))))))))]))) - (define-who loop-unroll-limit + (define-who loop-unroll-limit ($make-thread-parameter 0 ; NB: disabling loop unrolling for now (lambda (x) @@ -2428,14 +2428,14 @@ ;; Code growth computation is a little restrictive since it's measured ;; per loop... but maybe since new-size is weighted when profiling is ;; enabled it's fine. - #;(define CODE-GROWTH-FACTOR (fx1+ (loop-unroll-limit))) + #;(define CODE-GROWTH-FACTOR (fx1+ (loop-unroll-limit))) (define-syntax delay (syntax-rules () [(_ x) (lambda () x)])) (define (force x) (if (procedure? x) (x) x)) (define-who analyze-loops ;; -> (lambda () body) size new-weighted-size (lambda (body path-size unroll-count) - (with-output-language (L7 Expr) + (with-output-language (L7 Expr) ;; Not really a loop, just didn't want to pass around path-size and unroll-count when unnecessary (let loop ([body body]) (if (not body) @@ -2449,7 +2449,7 @@ (values (delay `(mref ,(force e1-promise) ,(force e2-promise) ,imm)) (fx+ e1-size e2-size 1) (fx+ e1-new-size e2-new-size 1))] - [,lvalue (values body 1 1)] + [,lvalue (values body 1 1)] [(profile ,src) (values body 0 0)] [(pariah) (values body 0 0)] [(label-ref ,l ,offset) (values body 0 0)] @@ -2471,23 +2471,23 @@ [query-count (if (or (not query-count) (< query-count .1)) 0 (exact (truncate (* query-count 1000))))] ;; allow path-size to increase up to 300 [adjusted-path-size-limit (fx+ PATH-SIZE-LIMIT (fx/ (or query-count 0) 5))] - ;; allow unroll limit to increase up to 4 + ;; allow unroll limit to increase up to 4 [adjusted-unroll-limit (fx+ (loop-unroll-limit) (fx/ (or query-count 0) 300))]) (if (or (fxzero? query-count) (fxzero? (fx+ unroll-count adjusted-unroll-limit)) (fx> path-size adjusted-path-size-limit)) - (begin + (begin (values (delay `(call ,info ,mdcl ,x ,(map force e*-promise) ...)) (fx1+ (apply fx+ size*)) - (fx1+ (apply fx+ new-size*)))) + (fx1+ (apply fx+ new-size*)))) (let*-values ([(var*) (car (uvar-location x))] [(loop-body-promise body-size new-size) (analyze-loops (cdr (uvar-location x)) (fx1+ path-size) (fx1- unroll-count))] [(new-size) ((lambda (x) (if query-count (fx/ x query-count) x)) (fx+ (length e*-promise) new-size))] [(acceptable-new-size) (fx* (fx1+ adjusted-unroll-limit) body-size)]) ;; NB: trying code growth computation here, where it could be per call site. - (values + (values (if (<= new-size acceptable-new-size) - (delay (fold-left + (delay (fold-left (lambda (body var e-promise) `(seq (set! ,var ,(force e-promise)) ,body)) (rename-loop-body (force loop-body-promise)) @@ -2511,7 +2511,7 @@ (values (delay `(foreign-call ,info ,(force e-promise) ,(map force e*-promise) ...)) (fx+ 5 e-size (apply fx+ size*)) (fx+ 5 e-new-size (apply fx+ new-size*)))] - [(label ,l ,[loop : body -> e size new-size]) + [(label ,l ,[loop : body -> e size new-size]) (values (delay `(label ,l ,(force e))) size new-size)] [(mvlet ,[loop : e -> e-promise e-size e-new-size] ((,x** ...) ,interface* ,body*) ...) (let-values ([(body*-promise body*-size body*-new-size) (mvmap 3 (lambda (e) (analyze-loops e (fx+ e-size path-size) unroll-count)) body*)]) @@ -2529,7 +2529,7 @@ (values (delay `(let ([,x* ,(map force e*-promise)] ...) ,(force body-promise))) (fx+ 1 body-size (apply fx+ size*)) (fx+ 1 body-new-size (apply fx+ new-size*))))] - [(if ,[loop : e0 -> e0-promise e0-size e0-new-size] ,e1 ,e2) + [(if ,[loop : e0 -> e0-promise e0-size e0-new-size] ,e1 ,e2) (let-values ([(e1-promise e1-size e1-new-size) (analyze-loops e1 (fx+ path-size e0-size) unroll-count)] [(e2-promise e2-size e2-new-size) (analyze-loops e2 (fx+ path-size e0-size) unroll-count)]) (values (delay `(if ,(force e0-promise) ,(force e1-promise) ,(force e2-promise))) @@ -2556,7 +2556,7 @@ [else ($oops who "forgot a case: ~a" body)])))))) (define-pass rename-loop-body : (L7 Expr) (ir) -> (L7 Expr) () - (definitions + (definitions (define-syntax with-fresh (syntax-rules () [(_ rename-ht x* body) @@ -2570,15 +2570,15 @@ [,x (eq-hashtable-ref rename-ht x x)] [(mref ,[e1] ,[e2] ,imm) `(mref ,e1 ,e2 ,imm)]) (Expr : Expr (ir rename-ht) -> Expr () - [(loop ,x (,[Lvalue : x* rename-ht -> x*] ...) ,body) - ;; NB: with-fresh is so well designed that it can't handle this case + [(loop ,x (,[Lvalue : x* rename-ht -> x*] ...) ,body) + ;; NB: with-fresh is so well designed that it can't handle this case (let*-values ([(x) (list x)] [(x body) (with-fresh rename-ht x (values (car x) (Expr body rename-ht)))]) `(loop ,x (,x* ...) ,body))] - [(let ([,x* ,[e*]] ...) ,body) - (with-fresh rename-ht x* + [(let ([,x* ,[e*]] ...) ,body) + (with-fresh rename-ht x* `(let ([,x* ,e*] ...) ,(Expr body rename-ht)))] - [(mvlet ,[e] ((,x** ...) ,interface* ,body*) ...) + [(mvlet ,[e] ((,x** ...) ,interface* ,body*) ...) (let* ([x**/body* (map (lambda (x* body) (with-fresh rename-ht x* (cons x* (Expr body rename-ht)))) x** body*)] @@ -2600,7 +2600,7 @@ (begin #;(printf "Opt: ~a\n" x) `(loop ,x (,x* ...) ,(force e-promise))) - (begin + (begin #;(printf "New size: ~a, old size: ~a\n" new-size size) ir)))])) (set! $loop-unroll-limit loop-unroll-limit)) @@ -3194,7 +3194,7 @@ (goto ,Lbig) ,(build-fix lo)) (label ,Lbig - ,(%seq + ,(%seq (set! ,%ac0 ,lo) (set! ,(ref-reg %ac1) ,hi) (set! ,%ac0 (inline ,(intrinsic-info-asmlib dofretuns64 #f) ,%asmlibcall)) @@ -3926,7 +3926,7 @@ [() `(immediate ,(fix base))] [e* (and (fx<= (length e*) (fx- inline-args-limit 1)) (list-bind #t (e*) - ;; NB: using inline-op here because it works when target's + ;; NB: using inline-op here because it works when target's ;; NB: fixnum range is larger than the host's fixnum range ;; NB: during cross compile (let-values ([(e e* nc*) (log-partition inline-op base e*)]) @@ -5128,7 +5128,7 @@ `(seq ,(build-dirty-store e-sym (constant symbol-value-disp) e-value) (set! ,(%mref ,e-sym ,(constant symbol-pvalue-disp)) - (literal + (literal ,(make-info-literal #f 'library (lookup-libspec nonprocedure-code) (constant code-data-disp))))))) @@ -5460,7 +5460,7 @@ (define (go3 e1 e2 e3) (bind #t (e2) (bind #f (e3) - (build-and + (build-and (go2 e1 e2) (go2 e2 e3))))) (define-inline 3 op @@ -7892,42 +7892,42 @@ (let () (define build-bytevector-ref-check (lambda (e-bits e-bv e-i check-mutable?) - (nanopass-case (L7 Expr) e-bits - [(quote ,d) - (guard (and (fixnum? d) (fx> d 0) (fx= (* (fxquotient d 8) 8) d))) - (let ([bits d] [bytes (fxquotient d 8)]) - (bind #t (e-bv e-i) - (build-and - (%type-check mask-typed-object type-typed-object ,e-bv) - (bind #t ([t (%mref ,e-bv ,(constant bytevector-type-disp))]) - (build-and - (if check-mutable? - (%type-check mask-mutable-bytevector type-mutable-bytevector ,t) - (%type-check mask-bytevector type-bytevector ,t)) - (cond - [(expr->index e-i bytes (constant maximum-bytevector-length)) => - (lambda (index) - (%inline u< - (immediate ,(logor (ash (+ index (fx- bytes 1)) (constant bytevector-length-offset)) - (constant type-bytevector))) - ,t))] - [else - (build-and - ($type-check (fxlogor (fix (fx- bytes 1)) (constant mask-fixnum)) (constant type-fixnum) e-i) + (nanopass-case (L7 Expr) e-bits + [(quote ,d) + (guard (and (fixnum? d) (fx> d 0) (fx= (* (fxquotient d 8) 8) d))) + (let ([bits d] [bytes (fxquotient d 8)]) + (bind #t (e-bv e-i) + (build-and + (%type-check mask-typed-object type-typed-object ,e-bv) + (bind #t ([t (%mref ,e-bv ,(constant bytevector-type-disp))]) + (build-and + (if check-mutable? + (%type-check mask-mutable-bytevector type-mutable-bytevector ,t) + (%type-check mask-bytevector type-bytevector ,t)) + (cond + [(expr->index e-i bytes (constant maximum-bytevector-length)) => + (lambda (index) (%inline u< - ; NB. add cannot overflow or change negative to positive when - ; low-order (log2 bytes) bits of fixnum value are zero, as - ; guaranteed by type-check above - ,(if (fx= bytes 1) - e-i - (%inline + ,e-i (immediate ,(fix (fx- bytes 1))))) - ,(%inline logand - ,(translate t - (constant bytevector-length-offset) - (constant fixnum-offset)) - (immediate ,(- (constant fixnum-factor))))))]))))))] - [(seq (profile ,src) ,[e]) (and e `(seq (profile ,src) ,e))] - [else #f]))) + (immediate ,(logor (ash (+ index (fx- bytes 1)) (constant bytevector-length-offset)) + (constant type-bytevector))) + ,t))] + [else + (build-and + ($type-check (fxlogor (fix (fx- bytes 1)) (constant mask-fixnum)) (constant type-fixnum) e-i) + (%inline u< + ; NB. add cannot overflow or change negative to positive when + ; low-order (log2 bytes) bits of fixnum value are zero, as + ; guaranteed by type-check above + ,(if (fx= bytes 1) + e-i + (%inline + ,e-i (immediate ,(fix (fx- bytes 1))))) + ,(%inline logand + ,(translate t + (constant bytevector-length-offset) + (constant fixnum-offset)) + (immediate ,(- (constant fixnum-factor))))))]))))))] + [(seq (profile ,src) ,[e]) (and e `(seq (profile ,src) ,e))] + [else #f]))) (define-inline 2 $bytevector-ref-check? [(e-bits e-bv e-i) (build-bytevector-ref-check e-bits e-bv e-i #f)]) (define-inline 2 $bytevector-set!-check? @@ -9065,7 +9065,7 @@ ,(u32xu32->ptr t-hi %real-zero)))])]) (define-inline 3 $read-performance-monitoring-counter - [(e) + [(e) (constant-case architecture [(x86) (%seq @@ -9275,7 +9275,7 @@ (unless (uvar-in-prefix? x) (uvar-in-prefix! x #t) (set! prefix* (cons x prefix*)))))) - (define add-prefix*! (lambda (x*) (for-each add-prefix! x*))) + (define add-prefix*! (lambda (x*) (for-each add-prefix! x*))) (define reset-prefix*! (lambda (orig-prefix*) (let loop ([ls prefix*] [diff* '()]) @@ -9440,7 +9440,7 @@ (define build-seq* (lambda (x* y) (fold-right build-seq y x*))) (with-output-language (L10 Expr) (define build-seq (lambda (x y) `(seq ,x ,y))) - (define Rhs + (define Rhs (lambda (ir lvalue) (Expr ir (lambda (e) @@ -9714,7 +9714,7 @@ ,(Pvalues #f (list tmp))))] [else ; set! & mvset `(seq ,e ,(Pvalues #f (list (%constant svoid))))])]) - (let-values ([(label* body*) + (let-values ([(label* body*) (let loop ([label* label*] [body* body*] [rlabel* '()] [rbody* '()]) (if (null? label*) (values rlabel* rbody*) @@ -9909,7 +9909,7 @@ (pariah) (mvcall ,(make-info-call #f #f #f #t #f) #f (literal ,(make-info-literal #f 'library - (if ioc + (if ioc (lookup-does-not-expect-headroom-libspec event) (lookup-libspec event)) 0)) @@ -12090,7 +12090,7 @@ `(lambda ,(make-info "$install-library-entry" '(2)) 0 () ,(%seq ,(with-saved-ret-reg - (%seq + (%seq ,(save-scheme-state (in scheme-args) (out %ac0 %ac1 %cp %xp %yp %ts %td extra-regs)) @@ -12429,7 +12429,7 @@ (define add-instr! (lambda (block ir) (block-effect*-set! block (cons ir (block-effect* block))))) - + (define add-label-link! (lambda (from l setter) (let ([x (local-label-block l)]) @@ -12443,7 +12443,7 @@ (safe-assert (not (block? x))) (when x (for-each (lambda (add-link!) (add-link! to)) x)) (local-label-block-set! l to)))) - + (define-pass build-graph : (L14 Tail) (ir) -> * (block block*) (definitions (define add-goto-block @@ -12653,7 +12653,7 @@ (include "types.ss") (let ([n (fx- ($block-counter) 1)]) ($block-counter n) - (block-pseudo-src-set! block + (block-pseudo-src-set! block (make-source ($sfd) n (block-checksum block))))) block*) ir])) @@ -12736,7 +12736,7 @@ [(lambda ,info ,max-fv (,local* ...) (,entry-block* ...) (,block* ...)) (safe-assert (not (ormap block-seen? block*))) ; optimistically assume all blocks are pariahs, then un-pariah anything reachable from - ; the entry block without going through a known pariah block + ; the entry block without going through a known pariah block (for-each (lambda (b) (if (block-pariah? b) (block-seen! b #t) (block-pariah! b #t))) block*) (for-each propagate! entry-block*) (for-each (lambda (b) (block-seen! b #f)) block*) @@ -12863,7 +12863,7 @@ [else (sorry! who "unrecognized block ~s" block)])]) (safe-assert (not (null? links))) ; AWK: we are missing the notion of those instructions that usually - ; succeed (dooverflow, dooverflood, call-error, fx+? and fx-? in + ; succeed (dooverflow, dooverflood, call-error, fx+? and fx-? in ; the original blocks.ss code) (let-values ([(pariah* non-pariah*) (partition (lambda (link) (block-pariah? (link-to link))) links)]) @@ -13010,7 +13010,7 @@ (cons* (car effect*) ir (cdr effect*)) (cons ir effect*)))))) (with-output-language (L15a Effect) - (add-instr! block + (add-instr! block `(inline ,(make-live-info) ,null-info ,%inc-profile-counter (literal ,(make-info-literal #t 'object counter (constant record-data-disp))) (immediate 1)))))) @@ -13068,8 +13068,8 @@ ; op -> counter | (plus-counter* . minus-counter*) ; plus-counter* -> (op ...) ; minus-counter* -> (op ...) - (define make-op - (lambda (plus minus) + (define make-op + (lambda (plus minus) ; optimize ((op) . ()) => op (if (and (null? minus) (fx= (length plus) 1)) (car plus) @@ -13109,7 +13109,7 @@ (link-op-set! l counter) counter))]))) (define (filter-src* block) - (cond + (cond [(eq? ($compile-profile) 'source) (block-src* block)] [(block-pseudo-src block) => list] [else '()])) @@ -13327,7 +13327,7 @@ [(newframe-block? block) (fprintf p " ~s\n" `(goto ,(block->pretty-name (newframe-block-next block))))] [else (sorry! who "unrecognized block ~s" block)])) block*))))) - + (define-pass np-add-in-links! : L15a (ir) -> L15a () (CaseLambdaExpr : CaseLambdaExpr (ir) -> CaseLambdaExpr () [(lambda ,info ,max-fv (,local* ...) (,entry-block* ...) (,block* ...)) @@ -13360,7 +13360,7 @@ (lambda (b) (unless (block-finished? b) (if (block-seen? b) - (begin + (begin (block-loop-header! b #t) (set! lh* (cons b lh*))) (begin @@ -14127,7 +14127,7 @@ (let ([out (if (info-kill*? info) (fold-left remove-var out (info-kill*-kill* info)) out)]) (live-info-live-set! live-info out) (let ([out (fold-left Triv out t*)]) - (if (info-kill*-live*? info) + (if (info-kill*-live*? info) (fold-left add-var out (info-kill*-live*-live* info)) out)))] [(remove-frame ,live-info ,info) (live-info-live-set! live-info out) out] @@ -14225,7 +14225,7 @@ (let ([call (add-var (fold-left (lambda (live* x*) (fold-left remove-var live* x*)) - rp + rp (cons* ; could base set of registers to kill on expected return values (reg-cons* %ret %ac0 arg-registers) @@ -14293,7 +14293,7 @@ (uvar-spilled! x #t) (unless (block-pariah? block) (uvar-save-weight-set! x - (fixnum + (fixnum (+ (uvar-save-weight x) (* (info-newframe-weight newframe-info) 2))))))) call-live*) @@ -14771,7 +14771,7 @@ (let ([effect* (block-effect* block)]) (block-fp-offset-set! block cur-off) (cond - [(goto-block? block) + [(goto-block? block) (record-fp-offsets! (goto-block-next block) (fold-left Effect cur-off effect*))] [(joto-block? block) (record-fp-offsets! (joto-block-next block) 0)] @@ -14932,7 +14932,7 @@ (define-pass literal@->literal : (L15c Triv) (ir) -> (L15d Triv) () (Triv : Triv (ir) -> Triv () [(literal ,info) - `(literal + `(literal ,(make-info-literal #f (info-literal-type info) (info-literal-addr info) (info-literal-offset info)))] [else (sorry! who "unexpected literal ~s" ir)])) @@ -15001,7 +15001,7 @@ (if force-overflow? (fxmax (fx- (fx* max-fs@call (constant ptr-bytes)) 0) - (fx- (fx* (fx+ max-fv 1) (constant ptr-bytes)) (fx- (constant stack-slop) (fx* (constant stack-frame-limit) 2)))) + (fx- (fx* (fx+ max-fv 1) (constant ptr-bytes)) (fx- (constant stack-slop) (fx* (constant stack-frame-limit) 2)))) (fxmax (fx- (fx* max-fs@call (constant ptr-bytes)) (constant stack-frame-limit)) (fx- (fx* (fx+ max-fv 1) (constant ptr-bytes)) (fx- (constant stack-slop) (constant stack-frame-limit))))))) diff --git a/s/date.ss b/s/date.ss index 0b714ee439..4bb7d61bfd 100644 --- a/s/date.ss +++ b/s/date.ss @@ -96,7 +96,7 @@ (scheme-object) scheme-object)) - (define $mktime ; dtvec -> tspair (returns #f on error) + (define $mktime ; dtvec -> tspair (returns #f on error) (foreign-procedure "(cs)mktime" (scheme-object) scheme-object)) @@ -389,10 +389,10 @@ ($oops 'make-date "invalid day ~s for month ~s and year ~s" day mon year)) (make-dt dtvec)))]) (case-lambda - [(nsec sec min hour day mon year tz) - (do-make-date nsec sec min hour day mon year tz #t)] - [(nsec sec min hour day mon year) - (do-make-date nsec sec min hour day mon year #f #f)]))) + [(nsec sec min hour day mon year tz) + (do-make-date nsec sec min hour day mon year tz #t)] + [(nsec sec min hour day mon year) + (do-make-date nsec sec min hour day mon year #f #f)]))) (set! date? (lambda (x) (dt? x))) diff --git a/workarea b/workarea index 2a9db42910..736ef4c6f1 100755 --- a/workarea +++ b/workarea @@ -33,10 +33,10 @@ fi case "$M" in a6fb) ;; a6le) ;; - a6ob) ;; - a6osx) ;; a6nb) ;; a6nt) ;; + a6ob) ;; + a6osx) ;; a6s2) ;; arm32le) ;; i3fb) ;; @@ -50,10 +50,10 @@ case "$M" in ppc32le) ;; ta6fb) ;; ta6le) ;; + ta6nb) ;; ta6nt) ;; ta6ob) ;; ta6osx) ;; - ta6nb) ;; ta6s2) ;; tarm32le) ;; ti3fb) ;; @@ -139,7 +139,6 @@ case $M in ;; esac - workdir $W/s (cd $W/s; workln ../../s/Mf-$M Mf-$M) (cd $W/s; forceworkln Mf-$M Makefile) From 029fe628f3faa86f12b65cc83afb25a894c11f3f Mon Sep 17 00:00:00 2001 From: Bob Burger Date: Mon, 30 Oct 2017 17:32:28 -0400 Subject: [PATCH 4/9] updated newrelease to handle mats/Mf-*nt original commit: 02a321479626d2a9e9f5ee0d5b4862eaed4859c8 --- LOG | 2 ++ mats/Mf-a6nt | 2 +- mats/Mf-i3nt | 2 +- mats/Mf-ta6nt | 2 +- mats/Mf-ti3nt | 2 +- newrelease | 6 ++++++ 6 files changed, 12 insertions(+), 4 deletions(-) diff --git a/LOG b/LOG index 1a470c5233..a56c45bb08 100644 --- a/LOG +++ b/LOG @@ -727,3 +727,5 @@ workarea, s/Mf-base, bytevector.ss, cpnanopass.ss, date.ss, 5_6.ms, examples.ms +- updated newrelease to handle mats/Mf-*nt + newrelease mats/Mf-a6nt mats/Mf-i3nt mats/Mf-ta6nt mats/Mf-ti3nt diff --git a/mats/Mf-a6nt b/mats/Mf-a6nt index 094b6187cb..093d0c3071 100644 --- a/mats/Mf-a6nt +++ b/mats/Mf-a6nt @@ -22,7 +22,7 @@ mdclean = cat_flush.exe cat_flush.obj foreign1.exp foreign1.lib foreign1.obj for include Mf-base foreign1.so: $(fsrc) - cmd.exe /c "vs.bat amd64 && cl /DWIN32 /DX86_64 /Fe$@ /I${Include} /LD /MD /nologo ../bin/$m/csv941.lib $(fsrc)" + cmd.exe /c "vs.bat amd64 && cl /DWIN32 /DX86_64 /Fe$@ /I${Include} /LD /MD /nologo ../bin/$m/csv951.lib $(fsrc)" cat_flush: cat_flush.c cmd.exe /c "vs.bat amd64 && cl /DWIN32 /DX86_64 /MD /nologo $<" diff --git a/mats/Mf-i3nt b/mats/Mf-i3nt index e76e0d35c0..572f66aeb6 100644 --- a/mats/Mf-i3nt +++ b/mats/Mf-i3nt @@ -22,7 +22,7 @@ mdclean = cat_flush.exe cat_flush.obj foreign1.exp foreign1.lib foreign1.obj for include Mf-base foreign1.so: $(fsrc) - cmd.exe /c "vs.bat x86 && cl /DWIN32 /Fe$@ /I${Include} /LD /MD /nologo ../bin/$m/csv941.lib $(fsrc)" + cmd.exe /c "vs.bat x86 && cl /DWIN32 /Fe$@ /I${Include} /LD /MD /nologo ../bin/$m/csv951.lib $(fsrc)" cat_flush: cat_flush.c cmd.exe /c "vs.bat x86 && cl /DWIN32 /MD /nologo $<" diff --git a/mats/Mf-ta6nt b/mats/Mf-ta6nt index c7fb204e58..16733d74c1 100644 --- a/mats/Mf-ta6nt +++ b/mats/Mf-ta6nt @@ -22,7 +22,7 @@ mdclean = cat_flush.exe cat_flush.obj foreign1.exp foreign1.lib foreign1.obj for include Mf-base foreign1.so: $(fsrc) - cmd.exe /c "vs.bat amd64 && cl /DWIN32 /DX86_64 /Fe$@ /I${Include} /LD /MD /nologo ../bin/$m/csv941.lib $(fsrc)" + cmd.exe /c "vs.bat amd64 && cl /DWIN32 /DX86_64 /Fe$@ /I${Include} /LD /MD /nologo ../bin/$m/csv951.lib $(fsrc)" cat_flush: cat_flush.c cmd.exe /c "vs.bat amd64 && cl /DWIN32 /DX86_64 /MD /nologo $<" diff --git a/mats/Mf-ti3nt b/mats/Mf-ti3nt index b6939e6d08..5059169016 100644 --- a/mats/Mf-ti3nt +++ b/mats/Mf-ti3nt @@ -22,7 +22,7 @@ mdclean = cat_flush.exe cat_flush.obj foreign1.exp foreign1.lib foreign1.obj for include Mf-base foreign1.so: $(fsrc) - cmd.exe /c "vs.bat x86 && cl /DWIN32 /Fe$@ /I${Include} /LD /MD /nologo ../bin/$m/csv941.lib $(fsrc)" + cmd.exe /c "vs.bat x86 && cl /DWIN32 /Fe$@ /I${Include} /LD /MD /nologo ../bin/$m/csv951.lib $(fsrc)" cat_flush: cat_flush.c cmd.exe /c "vs.bat x86 && cl /DWIN32 /MD /nologo $<" diff --git a/newrelease b/newrelease index a34e743770..01b7f5fdef 100755 --- a/newrelease +++ b/newrelease @@ -99,6 +99,12 @@ foreach fn (c/Makefile.{,t}{a6,i3}nt) sed -e "s/csv[0-9][0-9][0-9]*/csv$ZR/g" ../$fn > $fn end +/bin/rm -f mats/Mf-{,t}{i3,a6}nt +foreach fn (mats/Mf-{,t}{a6,i3}nt) + set updatedfiles = ($updatedfiles $fn) + sed -e "s/csv[0-9][0-9][0-9]*/csv$ZR/g" ../$fn > $fn +end + sed -e "s/csv[0-9][.0-9][0-9]*/csv$ZR/g" ../workarea > workarea chmod +x workarea set updatedfiles = ($updatedfiles workarea) From 64b0db8e30bab4c71f87904fa1ecc3636aeae478 Mon Sep 17 00:00:00 2001 From: dyb Date: Mon, 30 Oct 2017 21:01:43 -0400 Subject: [PATCH 5/9] fixed gather-filedata's sort of profile entries. for any two entries x and y in the list produced by the sort call, if x's bfp = y's bfp, x should come before y if x's efp < y's efp. The idea is that enclosing entries should always come later in the list. this affects only languages where two expressions can start at the same character position. pdhtml.ss expanded capability of ez-grammar with support for simpl parsing of binary operators w/precedence and associativity and automatically generated markdown grammar descriptions. ez-grammar-test.ss now also doubles as a test of pdhtml for algebraic languages. mats/examples.ms, examples/ez-grammar.ss, examples/ez-grammar-test.ss, examples/Makefile original commit: 53b8d16a1e86f3956585dbec0c7b573e485f7844 --- LOG | 15 + examples/Makefile | 2 +- examples/ez-grammar-test.ss | 361 +++++++++++++++-------- examples/ez-grammar.ss | 550 +++++++++++++++++++++++++++++++----- mats/examples.ms | 4 +- s/pdhtml.ss | 2 +- 6 files changed, 745 insertions(+), 189 deletions(-) diff --git a/LOG b/LOG index 1a470c5233..f4c4fdbe2b 100644 --- a/LOG +++ b/LOG @@ -727,3 +727,18 @@ workarea, s/Mf-base, bytevector.ss, cpnanopass.ss, date.ss, 5_6.ms, examples.ms +- fixed gather-filedata's sort of profile entries. for any two + entries x and y in the list produced by the sort call, if x's + bfp = y's bfp, x should come before y if x's efp < y's efp. + The idea is that enclosing entries should always come later + in the list. this affects only languages where two expressions + can start at the same character position. + pdhtml.ss +- expanded capability of ez-grammar with support for simpl + parsing of binary operators w/precedence and associativity + and automatically generated markdown grammar descriptions. + ez-grammar-test.ss now also doubles as a test of pdhtml for + algebraic languages. + mats/examples.ms, + examples/ez-grammar.ss, examples/ez-grammar-test.ss, + examples/Makefile diff --git a/examples/Makefile b/examples/Makefile index 5d0b987919..b1b4e1d1d5 100644 --- a/examples/Makefile +++ b/examples/Makefile @@ -25,4 +25,4 @@ needed: ${obj} all: ; echo "(time (for-each compile-file (map symbol->string '(${src}))))" | ${Scheme} -clean: ; /bin/rm -f $(obj) +clean: ; /bin/rm -f $(obj) expr.md diff --git a/examples/ez-grammar-test.ss b/examples/ez-grammar-test.ss index c9a8607d1e..3dd487187f 100644 --- a/examples/ez-grammar-test.ss +++ b/examples/ez-grammar-test.ss @@ -162,7 +162,7 @@ (unread-char c ip)) (define ($ws!) (set! $prev-pos $pos)) (define ($make-token type value) - (let ([tok (make-token type value $prev-pos (- $pos 1))]) + (let ([tok (make-token type value $prev-pos $pos)]) (set! $prev-pos $pos) tok)) (define ($lex-error c) @@ -198,7 +198,7 @@ [eof stream-nil] [char-whitespace? ($ws!) (lex)] [char-numeric? (lex-number c)] - [#\/ (seen-/)] + [#\/ (seen-slash)] [identifier-initial? (put-char sp c) (lex-identifier)] [#\( (return-token 'lparen #\()] [#\) (return-token 'rparen #\))] @@ -206,6 +206,9 @@ [#\+ (seen-plus)] [#\- (seen-minus)] [#\= (seen-equals)] + [#\* (return-token 'binop '*)] + [#\, (return-token 'sep #\,)] + [#\; (return-token 'sep #\;)] [else (lex-error c)]) (module (lex-identifier) (define (id) (return-token 'id (string->symbol (get-buf)))) @@ -215,22 +218,22 @@ [else ($unread-char c) (id)]) (define (lex-identifier) (next))) (define-state-case seen-plus c - [eof (lex-error c)] + [eof (return-token 'binop '+)] [char-numeric? (lex-signed-number #\+ c)] - [else (lex-error c)]) + [else (return-token 'binop '+)]) (define-state-case seen-minus c - [eof (lex-error c)] + [eof (return-token 'binop '-)] [char-numeric? (lex-signed-number #\- c)] - [else (lex-error c)]) + [else (return-token 'binop '-)]) (define-state-case seen-equals c - [eof (lex-error c)] + [eof (return-token 'binop '=)] [#\> (return-token 'big-arrow #f)] - [else (lex-error c)]) + [else (return-token 'binop '=)]) (module (lex-number lex-signed-number) (define (finish-number) (let ([str (get-buf)]) (let ([n (string->number str 10)]) - (unless n (errorf 'parse-ftc "unexpected number literal ~a" str)) + (unless n (errorf 'lexer "unexpected number literal ~a" str)) (return-token 'integer n)))) (define (num) (let ([c ($get-char)]) @@ -246,11 +249,11 @@ [eof (assert #f)] [char-numeric? (put-char sp c) (num)] [else (assert #f)]))) - (define-state-case seen-/ c - [eof (lex-error c)] + (define-state-case seen-slash c + [eof (return-token 'binop '/)] [#\* (lex-block-comment)] [#\/ (lex-comment)] - [else (lex-error c)]) + [else (return-token 'binop '/)]) (define-state-case lex-comment c [eof (lex)] [#\newline ($ws!) (lex)] @@ -281,34 +284,53 @@ (wr (token-efp x) p))) ) -(library (parser) - (export parse) +(module parser () + (export parse *sfd*) (import (chezscheme) (streams) (lexer)) + (define *sfd*) (module (define-grammar is sat parse-consumed-all? parse-result-value grammar-trace make-src) (define (sep->parser sep) (cond - [(char? sep) (sat (lambda (x) (eq? (token-value x) sep)))] + [(char? sep) (sat (lambda (x) (and (eq? (token-type x) 'sep) (eq? (token-value x) sep))))] [(symbol? sep) (sat (lambda (x) (eq? (token-type x) sep)))] [else (errorf "don't know how to parse separator: ~s" sep)])) (meta define (constant? x) (let ([x (syntax->datum x)]) (or (string? x) (char? x)))) (define constant->parser - (let () + (lambda (const) (define (token-sat type val) (sat (lambda (x) (let ([ans (and (token? x) (eqv? (token-type x) type) (eqv? (token-value x) val))]) (when (grammar-trace) (printf " ~s is [~s, ~a]? => ~s~%" x type val ans)) ans)))) - (lambda (const) - (if (string? const) - (case const - ["=>" (token-sat 'big-arrow #f)] - [else (token-sat 'id (string->symbol const))]) - (case const - [#\( (token-sat 'lparen const)] - [#\) (token-sat 'rparen const)] - [#\! (token-sat 'bang const)] - [else (errorf 'constant->parser "don't know how to construct a parser for ~a" const)]))))) - (define make-src (lambda (bfp efp) (and (<= bfp efp) (cons bfp efp)))) + (if (string? const) + (case const + [else (token-sat 'id (string->symbol const))]) + (case const + [#\( (token-sat 'lparen const)] + [#\) (token-sat 'rparen const)] + [#\! (token-sat 'bang const)] + [else (errorf 'constant->parser "don't know how to construct a parser for ~a" const)])))) + (meta define (constant->markdown k) + (format "~a" k)) + (define binop->parser + (lambda (binop) + (define (binop-sat type val) + (is val + (where [x <- item] (and (token? x) (eq? (token-type x) type) (eq? (token-value x) val))))) + (define (unexpected) (errorf 'binop->parser "don't know how to construct a parser for ~a" binop)) + (if (string? binop) + (binop-sat 'binop + (case binop + ["=" '=] + ["+" '+] + ["-" '-] + ["*" '*] + ["/" '/] + [else (unexpected)])) + (unexpected)))) + (define make-src + (lambda (bfp efp) + (make-source-object *sfd* bfp efp))) (include "ez-grammar.ss")) (define token @@ -330,102 +352,219 @@ (when (grammar-trace) (printf " ~s is [~s, ~s]? => ~s~%" x type val ans)) ans)))]))])) - (define-grammar expr - (expr - [integer :: src (token 'integer) => + (define identifier (token 'id)) + + (define integer (token 'integer)) + + (define-grammar expr (markdown-directory ".") + (TERMINALS + (identifier (x y) (DESCRIPTION ("An identifier is ..."))) + (integer (i) (DESCRIPTION ("An integer literal is ...")))) + (expr (e) + (BINOP src ((RIGHT "=") (LEFT "+" "-") (LEFT "*" "/")) t) => + (lambda (src op x y) + (make-annotation `(,op ,x ,y) src `(,op ,(annotation-stripped x) ,(annotation-stripped y))))) + (term (t) + [test-SEP+ :: src "sepplus" #\( (SEP+ e #\;) #\) => + (lambda (src e+) + (make-annotation `(SEP+ ,@e+) src `(SEP+ ,@(map annotation-stripped e+))))] + [test-SEP* :: src "sepstar" #\( (SEP* e #\,) #\) => + (lambda (src e*) + (make-annotation `(SEP* ,@e*) src `(SEP* ,@(map annotation-stripped e*))))] + [test-OPT :: src "opt" #\( (OPT e #f) #\) => + (lambda (src maybe-e) + (if maybe-e + (make-annotation `(OPT ,maybe-e) src `(OPT ,(annotation-stripped maybe-e))) + (make-annotation `(OPT) src `(OPT))))] + [test-K+ :: src "kplus" #\( (K+ e) #\) => + (lambda (src e+) + (make-annotation `(K+ ,@e+) src `(K+ ,@(map annotation-stripped e+))))] + [test-K* :: src "kstar" #\( (K* e) #\) => + (lambda (src e*) + (make-annotation `(K* ,@e*) src `(K* ,@(map annotation-stripped e*))))] + [varref :: src x => + (lambda (src id) + (make-annotation `(id ,id) src `(id ,id)))] + [intref :: src i => (lambda (src n) - `(int ,src ,n))] - [becomes :: src "=>" expr => - (lambda (src e) - `(=> ,src ,e))] - [becomes! :: src "=>" #\! expr => - (lambda (src e) - `(=>! ,src ,e))] - [group :: src #\( expr #\) => + (make-annotation `(int ,n) src `(int ,n)))] + [group :: src #\( e #\) => (lambda (src e) `(group ,src ,e))])) (define parse - (lambda (fn) - (let ([ip (open-input-file fn)]) - (dynamic-wind - void - (lambda () - (let ([token-stream (lexer fn ip)]) - (define (oops) - (let ([last-token (stream-last-forced token-stream)]) - (if last-token - (errorf 'parse "parse error at or before character ~s of ~a" (token-bfp last-token) fn) - (errorf 'parse "no expressions found in ~a" fn)))) -;;; return the first result, if any, for which the input stream was entirely consumed. - (let loop ([res* (expr token-stream)]) - (if (null? res*) - (oops) - (let ([res (car res*)]) - (if (parse-consumed-all? res) - (parse-result-value res) - (loop (cdr res*)))))))) - (lambda () (close-input-port ip)))))) - ) + (lambda (fn ip) + (let ([token-stream (lexer fn ip)]) + (define (oops) + (let ([last-token (stream-last-forced token-stream)]) + (if last-token + (errorf 'parse "parse error at or before character ~s of ~a" (token-bfp last-token) fn) + (errorf 'parse "no expressions found in ~a" fn)))) + ;;; return the first result, if any, for which the input stream was entirely consumed. + (let loop ([res* (expr token-stream)]) + (if (null? res*) + (oops) + (let ([res (car res*)]) + (if (parse-consumed-all? res) + (parse-result-value res) + (loop (cdr res*)))))))))) + +(define run + (lambda (fn) + (import parser) + (let* ([ip (open-file-input-port fn)] + [sfd (make-source-file-descriptor fn ip #t)] + [ip (transcoded-port ip (native-transcoder))]) + (fluid-let ([*sfd* sfd]) + (eval + `(let () + (define-syntax define-ops + (lambda (x) + (syntax-case x () + [(_ op ...) + #`(begin + (define-syntax op + (lambda (x) + (let ([src (annotation-source (syntax->annotation x))]) + (with-syntax ([bfp (source-object-bfp src)] [efp (source-object-efp src)]) + (syntax-case x () + [(_ e (... ...)) #'`(op (bfp . efp) ,e (... ...))]))))) + ...)]))) + (define-ops SEP+ SEP* OPT K+ K* id int group) + (define-ops = + - * /) + (define x 'x) + (define y 'y) + (define z 'z) + ,(dynamic-wind + void + (lambda () (parse fn ip)) + (lambda () (close-input-port ip))))))))) (define (ez-grammar-test) - (import (parser)) - (with-output-to-file "ez-grammar-test1" - (lambda () - (for-each display - '( - "1347\n" - ))) - 'replace) + (define n 0) + (define test + (lambda (line* okay?) + (set! n (+ n 1)) + (let ([fn (format "testfile~s" n)]) + (with-output-to-file fn + (lambda () (for-each (lambda (line) (printf "~a\n" line)) line*)) + 'replace) + (let ([result (parameterize ([compile-profile #t] [compile-interpret-simple #f]) + (guard (c [else c]) (run fn)))]) + (guard (c [else #f]) (profile-dump-html)) + (delete-file fn) + (delete-file "profile.html") + (delete-file (format "~a.html" fn)) + (unless (okay? result) + (printf "test ~s failed\n" n) + (printf " test code:") + (for-each (lambda (line) (printf " ~a\n" line)) line*) + (printf " result:\n ") + (if (condition? result) + (begin (display-condition result) (newline)) + (parameterize ([pretty-initial-indent 4]) + (pretty-print result))) + (newline)))))) - (with-output-to-file "ez-grammar-test2" - (lambda () - (for-each display - '( - "\n" - "/* hello */ => ( => 1253) /* goodbye\n" - " 111111111122222222223333333333\n" - "123456789012345678901234567890123456789\n" - "*/\n" - ))) - 'replace) + (define-syntax returns + (syntax-rules () + [(_ k) (lambda (x) (equal? x 'k))])) - (with-output-to-file "ez-grammar-test3err" - (lambda () - (for-each display - '( - "\n" - "/* hello */ => (=> 1253 =>) /* goodbye\n" - " 111111111122222222223333333333\n" - "123456789012345678901234567890123456789\n" - "*/\n" - ))) - 'replace) + (define-syntax oops + (syntax-rules () + [(_ (c) e1 e2 ...) + (lambda (c) (and (condition? c) e1 e2 ...))])) - (with-output-to-file "ez-grammar-test4err" - (lambda () - (for-each display - '( - "3 /*\n" - ))) - 'replace) + (test + '( + "1347" + ) + (returns + (int (0 . 4) 1347))) - (unless (guard (c [else #f]) (equal? (parse "ez-grammar-test1") (quote (int (0 . 3) 1347)))) - (printf "test 1 failed\n")) - (delete-file "ez-grammar-test1") - (unless (guard (c [else #f]) (equal? (parse "ez-grammar-test2") (quote (=> (13 . 25) (group (16 . 25) (=> (18 . 24) (int (21 . 24) 1253))))))) - (printf "test 2 failed\n")) - (delete-file "ez-grammar-test2") - (unless (guard (c [else (and (equal? (condition-message c) "parse error at or before character ~s of ~a") (equal? (condition-irritants c) (quote (25 "ez-grammar-test3err"))))]) (parse "ez-grammar-test3err") #f) - (printf "test 3 failed\n")) - (delete-file "ez-grammar-test3err") - (unless (guard (c [else (and (equal? (condition-message c) "unexpected ~a at character ~s of ~a") (equal? (condition-irritants c) (quote ("eof" 6 "ez-grammar-test4err"))))]) (parse "ez-grammar-test4err") #f) - (printf "test 4 failed\n")) - (delete-file "ez-grammar-test4err") - (printf "end of tests\n")) + (test + '( + "3 /*" + ) + (oops (c) + (equal? (condition-message c) "unexpected ~a at character ~s of ~a") + (equal? (condition-irritants c) '("eof" 6 "testfile2")))) + + (test + '( + "3 / 4 + 5 opt(6)" + ) + (oops (c) + (equal? (condition-message c) "parse error at or before character ~s of ~a") + (equal? (condition-irritants c) '(10 "testfile3")))) + + (test + '( + "x = y = 5" + ) + (returns + (= + (0 . 9) + (id (0 . 1) x) + (= (4 . 9) (id (4 . 5) y) (int (8 . 9) 5))))) + + (test + '( + "x = y = x + 5 - z * 7 + 8 / z" + ) + (returns + (= + (0 . 29) + (id (0 . 1) x) + (= + (4 . 29) + (id (4 . 5) y) + (+ + (8 . 29) + (- + (8 . 21) + (+ (8 . 13) (id (8 . 9) x) (int (12 . 13) 5)) + (* (16 . 21) (id (16 . 17) z) (int (20 . 21) 7))) + (/ (24 . 29) (int (24 . 25) 8) (id (28 . 29) z))))))) + + (test + '( + "opt(opt(opt()))" + ) + (returns + (OPT (0 . 15) (OPT (4 . 14) (OPT (8 . 13)))))) + + (test + '( + "kstar(3 4 kplus(1 2 3 kstar()))" + ) + (returns + (K* (0 . 31) + (int (6 . 7) 3) + (int (8 . 9) 4) + (K+ (10 . 30) + (int (16 . 17) 1) + (int (18 . 19) 2) + (int (20 . 21) 3) + (K* (22 . 29)))))) + + (test + '( + "sepplus( opt() ; opt(5) ; sepstar(17, 34) ; sepstar())" + ) + (returns + (SEP+ (0 . 54) + (OPT (9 . 14)) + (OPT (17 . 23) (int (21 . 22) 5)) + (SEP* (26 . 41) (int (34 . 36) 17) (int (38 . 40) 34)) + (SEP* (44 . 53))))) + + (delete-file "expr.md") + (printf "~s tests ran\n" n) + ) #!eof -The following should print only "end of tests". +The following should print only " tests ran". -echo '(ez-grammar-test)' | scheme -q ez-grammar-test.ss +echo '(ez-grammar-test)' | ../bin/scheme -q ez-grammar-test.ss diff --git a/examples/ez-grammar.ss b/examples/ez-grammar.ss index 744217793f..1d95dd806b 100644 --- a/examples/ez-grammar.ss +++ b/examples/ez-grammar.ss @@ -44,7 +44,7 @@ ;;; See ez-grammar-test.ss for an example. (module (define-grammar - is sat peek seq ++ +++ many many+ ? + is sat item peek seq ++ +++ many many+ ? parse-consumed-all? parse-result-value parse-result-unused grammar-trace ) @@ -54,6 +54,7 @@ (define-record-type parse-result (nongenerative parse-result) + (sealed #t) (fields value unused)) ;; to enable $trace-is to determine the ending file position (efp) of a parse @@ -144,7 +145,7 @@ (define ($trace-is name proc head) (lambda (unused) (let ([res (proc (token-bfp (current-token head)) (token-efp (preceding-token unused)))]) - (when (and 'name (grammar-trace)) (printf "<<~s = ~s~%" 'name res)) + (when (and name (grammar-trace)) (printf "<<~s = ~s~%" name res)) (stream (make-parse-result res unused))))) (define-syntax trace-is @@ -203,6 +204,46 @@ (define (+++ p q) (first (++ p q))) ;; choose first match, cut backtracking + (define-syntax infix-expression-parser + (lambda (x) + (syntax-case x () + [(_ ((L/R ?op-parser) ...) ?term-parser ?receiver) + (with-syntax ([(op-parser ...) (generate-temporaries #'(?op-parser ...))]) + #`(let ([op-parser ?op-parser] ... [term-parser (lambda (inp) (?term-parser inp))] [receiver ?receiver]) + #,(let f ([ls #'((L/R op-parser) ...)]) + (if (null? ls) + #'term-parser + #`(let ([next #,(f (cdr ls))]) + #,(syntax-case (car ls) (LEFT RIGHT) + [(LEFT op-parser) + #'(let () + (define-record-type frob (nongenerative) (sealed #t) (fields op y efp)) + (trace-is binop-left (lambda (bfp ignore-this-efp) + (fold-left + (lambda (x f) (receiver bfp (frob-efp f) (frob-op f) x (frob-y f))) + x f*)) + (where + [x <- next] + [f* <- (rec this + (optional + (is (cons f f*) + (where + [f <- (trace-is binop-left-tail (lambda (bfp efp) (make-frob op y efp)) + (where + [op <- op-parser] + [y <- next]))] + [f* <- this])) + '()))])))] + [(RIGHT op-parser) + #'(rec this + (+++ + (trace-is binop-right (lambda (bfp efp) (receiver bfp efp op x y)) + (where + [x <- next] + [op <- op-parser] + [y <- this])) + next))]))))))]))) + (define (format-inp inp) (if (no-more-tokens? inp) "#" @@ -210,43 +251,132 @@ (define-syntax define-grammar (lambda (x) - (define-record-type production + (define-record-type grammar (nongenerative) - (fields name elt* receiver)) + (sealed #t) + (fields title paragraph* section*)) + (define-record-type section + (nongenerative) + (sealed #t) + (fields title paragraph* suppressed? clause*)) (define-record-type clause (nongenerative) - (fields id prod*)) + (fields id alias* before-paragraph* after-paragraph*)) + (define-record-type regular-clause + (nongenerative) + (sealed #t) + (parent clause) + (fields prod*)) + (define-record-type binop-clause + (nongenerative) + (sealed #t) + (parent clause) + (fields level* term receiver) + (protocol + (lambda (pargs->new) + (lambda (nt alias* before-paragraph* after-paragraph* level* term src? receiver) + ((pargs->new nt alias* before-paragraph* after-paragraph*) level* term + #`(lambda (bfp efp op x y) + #,(if src? + #`(#,receiver (make-src bfp efp) op x y) + #`(#,receiver op x y)))))))) + (define-record-type terminal-clause + (nongenerative) + (sealed #t) + (fields term*)) + (define-record-type terminal + (nongenerative) + (sealed #t) + (fields parser alias* paragraph*)) + (define-record-type production + (nongenerative) + (sealed #t) + (fields name paragraph* elt* receiver) + (protocol + (let () + (define (check-elts elt*) + (for-each (lambda (elt) (unless (elt? elt) (errorf 'make-production "~s is not an elt" elt))) elt*)) + (lambda (new) + (case-lambda + [(name elt* receiver) + (check-elts elt*) + (new name #f elt* receiver)] + [(name paragraph* elt* receiver) + (check-elts elt*) + (new name paragraph* elt* receiver)]))))) + (define-record-type elt + (nongenerative)) + (define-record-type sep-elt + (nongenerative) + (sealed #t) + (parent elt) + (fields +? elt sep)) + (define-record-type opt-elt + (nongenerative) + (sealed #t) + (parent elt) + (fields elt default)) + (define-record-type kleene-elt + (nongenerative) + (sealed #t) + (parent elt) + (fields +? elt)) + (define-record-type constant-elt + (nongenerative) + (sealed #t) + (parent elt) + (fields k)) + (define-record-type id-elt + (nongenerative) + (sealed #t) + (parent elt) + (fields id)) + (define paragraph? + (lambda (x) + (syntax-case x (include) + [(include filename) (string? (datum filename))] + [(str ...) (andmap string? (datum (str ...)))]))) (define (gentemp) (datum->syntax #'* (gensym))) (define (elt-temps elt*) + (for-each (lambda (elt) (unless (elt? elt) (errorf 'elt-temps "~s is not an elt" elt))) elt*) (fold-left (lambda (t* elt) - (if (constant? elt) t* (cons (gentemp) t*))) + (if (constant-elt? elt) t* (cons (gentemp) t*))) '() elt*)) - (define parse-production - (lambda (cl) - (syntax-case cl (:: src =>) - [[name :: src elt ... => receiver] - (make-production #'name #'(elt ...) - (with-syntax ([(t ...) (elt-temps #'(elt ...))]) - #'(lambda (bfp efp t ...) - (receiver (make-src bfp efp) t ...))))] - [[name :: elt ... => receiver] - (make-production #'name #'(elt ...) - (with-syntax ([(t ...) (elt-temps #'(elt ...))]) - #'(lambda (bfp efp t ...) - (receiver t ...))))]))) (define (left-factor clause*) (define syntax-equal? (lambda (x y) (equal? (syntax->datum x) (syntax->datum y)))) + (define (elt-equal? x y) + (cond + [(sep-elt? x) + (and (sep-elt? y) + (eq? (sep-elt-+? x) (sep-elt-+? y)) + (elt-equal? (sep-elt-elt x) (sep-elt-elt y)) + (syntax-equal? (sep-elt-sep x) (sep-elt-sep y)))] + [(opt-elt? x) + (and (opt-elt? y) + (elt-equal? (opt-elt-elt x) (opt-elt-elt y)) + (syntax-equal? (opt-elt-default x) (opt-elt-default y)))] + [(kleene-elt? x) + (and (kleene-elt? y) + (eq? (kleene-elt-+? x) (kleene-elt-+? y)) + (elt-equal? (kleene-elt-elt x) (kleene-elt-elt y)))] + [(constant-elt? x) + (and (constant-elt? y) + (syntax-equal? (constant-elt-k x) (constant-elt-k y)))] + [(id-elt? x) + (and (id-elt? y) + (syntax-equal? (id-elt-id x) (id-elt-id y)))] + [else #f])) (let lp1 ([clause* clause*] [new-clause* '()]) (if (null? clause*) (reverse new-clause*) (let ([clause (car clause*)]) - (let lp2 ([prod* (clause-prod* clause)] [new-prod* '()] [clause* (cdr clause*)]) + (let lp2 ([prod* (regular-clause-prod* clause)] [new-prod* '()] [clause* (cdr clause*)]) (if (null? prod*) - (lp1 clause* (cons (make-clause (clause-id clause) (reverse new-prod*)) new-clause*)) + (lp1 clause* (cons (make-regular-clause (clause-id clause) (clause-alias* clause) '() '() (reverse new-prod*)) new-clause*)) (let ([prod (car prod*)] [prod* (cdr prod*)]) (let ([elt* (production-elt* prod)]) (if (null? elt*) @@ -256,7 +386,7 @@ (lambda (prod) (let ([elt* (production-elt* prod)]) (and (not (null? elt*)) - (syntax-equal? (car elt*) elt)))) + (elt-equal? (car elt*) elt)))) prod*)]) (if (null? haves) (lp2 prod* (cons prod new-prod*) clause*) @@ -269,15 +399,15 @@ (if (ormap null? elt**) '() (let ([elt (caar elt**)]) - (if (andmap (lambda (elt*) (syntax-equal? (car elt*) elt)) (cdr elt**)) - (cons (caar elt**) (f elt**)) + (if (andmap (lambda (elt*) (elt-equal? (car elt*) elt)) (cdr elt**)) + (cons elt (f elt**)) '()))))))]) (let ([t (gentemp)] [n (length prefix)] [t* (elt-temps prefix)]) (lp2 have-nots - (cons (make-production #f (append prefix (list t)) + (cons (make-production #f (append prefix (list (make-id-elt t))) #`(lambda (bfp efp #,@t* p) (p bfp #,@t*))) new-prod*) - (cons (make-clause t + (cons (make-regular-clause t '() '() '() (map (lambda (prod) (let ([elt* (list-tail (production-elt* prod) n)]) (make-production (production-name prod) elt* @@ -287,54 +417,325 @@ (#,(production-receiver prod) bfp efp #,@t* #,@u*))))))) haves)) clause*))))))))))))))))) - (define (nt-helper clause*) - (define (elt-helper x) - (syntax-case x (SEP+ SEP* OPT K* K+) - [(SEP+ p sep) #`(sepby1 #,(elt-helper #'p) (sep->parser sep))] - [(SEP* p sep) #`(sepby #,(elt-helper #'p) (sep->parser sep))] - [(OPT p dflt) #`(optional #,(elt-helper #'p) dflt)] - [(K* p) #`(many #,(elt-helper #'p))] - [(K+ p) #`(many+ #,(elt-helper #'p))] - [k (constant? #'k) #'(constant->parser 'k)] - [p #'p])) - (let loop ([clause* clause*] [binding* '()]) - (if (null? clause*) - binding* - (loop - (cdr clause*) - (cons - #`[#,(clause-id (car clause*)) - #,(let f ([prod* (clause-prod* (car clause*))]) - (if (null? prod*) - #'zero - (with-syntax ([name (production-name (car prod*))] - [(elt ...) (production-elt* (car prod*))] - [receiver (production-receiver (car prod*))]) - (with-syntax ([(x ...) (generate-temporaries #'(elt ...))]) - (with-syntax ([([y _] ...) (filter (lambda (pr) (not (constant? (cadr pr)))) #'([x elt] ...))]) - (with-syntax ([(where-nt ...) (map elt-helper #'(elt ...))]) - #`(+++ ;; use +++ if you don't ever need to backtrack to a previous production for the same non-terminal - (lambda (inp) - (when (and 'name (grammar-trace)) (printf ">>~s(~a)~%" 'name (format-inp inp))) - (let ([res ((trace-is name (lambda (bfp efp) (receiver bfp efp y ...)) (where [x <- where-nt] ...)) inp)]) - (when (and 'name (grammar-trace)) - (if (stream-null? res) - (printf "<<~s(~a) failed~%" 'name (format-inp inp)) - (printf "<<~s(~a) succeeded~%" 'name (format-inp inp)))) - res)) - #,(f (cdr prod*)))))))))] - binding*))))) - (syntax-case x () - [(_ init-nt [nt prod prods ...] ...) - (with-syntax ([(binding ...) - (nt-helper - (left-factor - (map (lambda (nt prod*) (make-clause nt (map parse-production prod*))) - #'(nt ...) - #'((prod prods ...) ...))))]) - #'(define init-nt - (letrec (binding ...) - (make-top-level-parser init-nt))))]))) + (define (make-env tclause* clause*) + (let ([env (make-hashtable (lambda (x) (symbol-hash (syntax->datum x))) free-identifier=?)]) + (define (insert parser) + (lambda (name) + (let ([a (hashtable-cell env name #f)]) + (when (cdr a) (syntax-error name "duplicate terminal/non-terminal name")) + (set-cdr! a parser)))) + (for-each + (lambda (tclause) + (for-each + (lambda (term) + (let ([parser (terminal-parser term)]) + (for-each (insert parser) (cons parser (terminal-alias* term))))) + (terminal-clause-term* tclause))) + tclause*) + (for-each + (lambda (clause) + (let ([id (clause-id clause)]) + (for-each (insert id) (cons id (clause-alias* clause))))) + clause*) + env)) + (define (lookup id env) + (or (hashtable-ref env id #f) + (syntax-error id "unrecognized terminal or nonterminal"))) + (define (render-markdown name grammar mdfn env) + (define (separators sep ls) + (if (null? ls) + "" + (apply string-append + (cons (car ls) + (map (lambda (s) (format "~a~a" sep s)) (cdr ls)))))) + (define (render-paragraph hard-leading-newline?) + (lambda (paragraph) + (define (md-text s) + (list->string + (fold-right + (lambda (c ls) + (case c + [(#\\) (cons* c c ls)] + [else (cons c ls)])) + '() + (string->list s)))) + (syntax-case paragraph (include) + [(include filename) + (string? (datum filename)) + (let ([text (call-with-port (open-input-file (datum filename)) get-string-all)]) + (unless (equal? text "") + (if hard-leading-newline? (printf "\\\n") (newline)) + (display-string text)))] + [(sentence ...) + (andmap string? (datum (sentence ...))) + (let ([sentence* (datum (sentence ...))]) + (unless (null? sentence*) + (if hard-leading-newline? (printf "\\\n") (newline)) + (printf "~a\n" (separators " " (map md-text sentence*)))))]))) + (define (format-elt x) + (cond + [(sep-elt? x) + (let* ([one (format-elt (sep-elt-elt x))] + [sep (constant->markdown (syntax->datum (sep-elt-sep x)))] + [seq (format "~a  ~a  `...`" one sep)]) + (if (sep-elt-+? x) + seq + (format "OPT(~a)" seq)))] + [(opt-elt? x) + (format "~a~~opt~~" (format-elt (opt-elt-elt x)))] + [(kleene-elt? x) + (let ([one (format-elt (kleene-elt-elt x))]) + (if (kleene-elt-+? x) + (format "~a  `...`" one) + (format "OPT(~a)" one)))] + [(constant-elt? x) (constant->markdown (syntax->datum (constant-elt-k x)))] + [(id-elt? x) (format "[*~s*](#~s)" + (syntax->datum (id-elt-id x)) + (syntax->datum (lookup (id-elt-id x) env)))] + [else (errorf 'format-elt "unexpected elt ~s" x)])) + (define (render-elt x) + (printf "  ~a" (format-elt x))) + (define (render-production prod) + (unless (null? (production-elt* prod)) + (printf " : ") + (for-each render-elt (production-elt* prod)) + (printf "\n")) + (when (and (null? (production-elt* prod)) + (not (null? (production-paragraph* prod)))) + (errorf 'render-production "empty production must not have description: ~a" (production-paragraph* prod))) + (for-each (render-paragraph #t) (production-paragraph* prod))) + (define (render-clause clause) + (define (render-aliases alias*) + (unless (null? alias*) + (printf " \naliases: ~{*~a*~^, ~}\n" (map syntax->datum alias*)))) + (if (terminal-clause? clause) + (for-each + (lambda (term) + (printf "\n#### *~a* {#~:*~a}\n" (syntax->datum (terminal-parser term))) + (render-aliases (terminal-alias* term)) + (for-each (render-paragraph #f) (terminal-paragraph* term))) + (terminal-clause-term* clause)) + (let ([id (syntax->datum (clause-id clause))]) + (printf "\n#### *~a* {#~:*~a}\n" id) + (render-aliases (clause-alias* clause)) + (for-each (render-paragraph #f) (clause-before-paragraph* clause)) + (printf "\nsyntax:\n") + (if (binop-clause? clause) + (let ([level* (binop-clause-level* clause)]) + (let loop ([level* level*] [first? #t]) + (unless (null? level*) + (let ([level (syntax->datum (car level*))] [level* (cdr level*)]) + (let ([L/R (car level)] [op* (cdr level)]) + (printf " : _~(~a~)-associative" L/R) + (if first? + (if (null? level*) + (printf ":_\n") + (printf ", highest precedence:_\n")) + (if (null? level*) + (printf ", lowest precedence:_\n") + (printf ":_\n"))) + (for-each + (lambda (op) (printf " : ~s ~a ~s\n" id (constant->markdown op) id)) + op*)) + (loop level* #f)))) + (printf " : _leaves:_\n") + (printf " : ") + (render-elt (binop-clause-term clause)) + (printf "\n")) + (for-each render-production (or (regular-clause-prod* clause) '()))) + (for-each (render-paragraph #f) (clause-after-paragraph* clause))))) + (define (render-section section) + (unless (section-suppressed? section) + (printf "\n## ~a\n" (or (section-title section) "The section")) + (for-each (render-paragraph #f) (section-paragraph* section)) + (for-each render-clause (section-clause* section)))) + (with-output-to-file mdfn + (lambda () + (printf "# ~a\n" (or (grammar-title grammar) "The grammar")) + (for-each (render-paragraph #f) (grammar-paragraph* grammar)) + (for-each render-section (grammar-section* grammar))) + 'replace)) + (module (parse-grammar) + (define parse-elt + (lambda (elt) + (syntax-case elt (SEP+ SEP* OPT K* K+) + [(SEP+ p sep) (make-sep-elt #t (parse-elt #'p) #'sep)] + [(SEP* p sep) (make-sep-elt #f (parse-elt #'p) #'sep)] + [(OPT p default) (make-opt-elt (parse-elt #'p) #'default)] + [(K+ p) (make-kleene-elt #t (parse-elt #'p))] + [(K* p) (make-kleene-elt #f (parse-elt #'p))] + [k (constant? #'k) (make-constant-elt #'k)] + [id (identifier? #'id) (make-id-elt #'id)] + [_ (syntax-error elt "invalid production element")]))) + (define parse-production + (lambda (prod) + (define (finish name src? paragraph* elt* receiver) + (let ([elt* (map parse-elt elt*)]) + (make-production name paragraph* elt* + (with-syntax ([(t ...) (elt-temps elt*)]) + #`(lambda (bfp efp t ...) + #,(if src? + #`(#,receiver (make-src bfp efp) t ...) + #`(#,receiver t ...))))))) + (syntax-case prod (:: src =>) + [[name :: src elt ... => receiver] + (finish #'name #t '() #'(elt ...) #'receiver)] + [[name :: elt ... => receiver] + (finish #'name #f '() #'(elt ...) #'receiver)]))) + (define (parse-terminal term) + (syntax-case term (DESCRIPTION) + [(parser (alias ...) (DESCRIPTION paragraph ...)) + (and (identifier? #'parser) (andmap identifier? #'(alias ...)) (andmap paragraph? #'(paragraph ...))) + (make-terminal #'parser #'(alias ...) #'(paragraph ...))] + [(parser (alias ...)) + (and (identifier? #'parser) (andmap identifier? #'(alias ...))) + (make-terminal #'parser #'(alias ...) '())])) + (define (parse-clause clause nt alias* before-paragraph* after-paragraph* stuff*) + (syntax-case stuff* (BINOP :: src =>) + [((BINOP src (level ...) term) => receiver) + (make-binop-clause nt alias* before-paragraph* after-paragraph* #'(level ...) (parse-elt #'term) #t #'receiver)] + [((BINOP (level ...) term) => receiver) + (make-binop-clause nt alias* before-paragraph* after-paragraph* #'(level ...) (parse-elt #'term) #f #'receiver)] + [(prod prods ...) + (make-regular-clause nt alias* before-paragraph* after-paragraph* (map parse-production #'(prod prods ...)))] + [else (syntax-error clause)])) + (define (parse-top top* knull kgrammar ksection kclause) + (if (null? top*) + (knull) + (let ([top (car top*)] [top* (cdr top*)]) + (syntax-case top (GRAMMAR SECTION SUPPRESSED DESCRIPTION BINOP TERMINALS src =>) + [(GRAMMAR title paragraph ...) + (andmap paragraph? #'(paragraph ...)) + (kgrammar top* (datum title) #'(paragraph ...))] + [(SECTION SUPPRESSED title paragraph ...) + (andmap paragraph? #'(paragraph ...)) + (ksection top* (datum title) #'(paragraph ...) #t)] + [(SECTION title paragraph ...) + (andmap paragraph? #'(paragraph ...)) + (ksection top* (datum title) #'(paragraph ...) #f)] + [(TERMINALS term ...) + (kclause top* (make-terminal-clause (map parse-terminal #'(term ...))))] + [(TERMINALS term ...) + (kclause top* (make-terminal-clause (map parse-terminal #'(term ...))))] + [(nt (alias ...) (DESCRIPTION paragraph1 ...) stuff ... (DESCRIPTION paragraph2 ...)) + (and (identifier? #'nt) (andmap identifier? #'(alias ...)) (andmap paragraph? #'(paragraph1 ...)) (andmap paragraph? #'(paragraph2 ...))) + (kclause top* (parse-clause top #'nt #'(alias ...) #'(paragraph1 ...) #'(paragraph2 ...) #'(stuff ...)))] + [(nt (alias ...) (DESCRIPTION paragraph ...) stuff ...) + (and (identifier? #'nt) (andmap identifier? #'(alias ...)) (andmap paragraph? #'(paragraph ...))) + (kclause top* (parse-clause top #'nt #'(alias ...) #'(paragraph ...) '() #'(stuff ...)))] + [(nt (alias ...) stuff ... (DESCRIPTION paragraph ...)) + (and (identifier? #'nt) (andmap identifier? #'(alias ...)) (andmap paragraph? #'(paragraph ...))) + (kclause top* (parse-clause top #'nt #'(alias ...) '() #'(paragraph ...) #'(stuff ...)))] + [(nt (alias ...) stuff ...) + (and (identifier? #'nt) (andmap identifier? #'(alias ...))) + (kclause top* (parse-clause top #'nt #'(alias ...) '() '() #'(stuff ...)))])))) + (define (parse-grammar top*) + (define (misplaced-grammar-error top) + (syntax-error top "unexpected GRAMMAR element after other elements")) + (define (s1 top*) ; looking for GRAMMAR form, first SECTION form, or clause + (parse-top top* + (lambda () (make-grammar #f '() '())) + (lambda (top* title paragraph*) + (make-grammar title paragraph* (s2 top*))) + (lambda (top* title paragraph* suppressed?) + (make-grammar #f '() + (s3 top* title paragraph* suppressed? '() '()))) + (lambda (top* clause) + (make-grammar #f '() + (s3 top* #f '() #f (list clause) '()))))) + (define (s2 top*) ; looking for first SECTION form or clause + (parse-top top* + (lambda () '()) + (lambda (title paragraph*) (misplaced-grammar-error (car top*))) + (lambda (top* title paragraph* suppressed?) + (s3 top* title paragraph* suppressed? '() '())) + (lambda (top* clause) + (s3 top* #f '() #f (list clause) '())))) + (define (s3 top* title paragraph* suppressed? rclause* rsection*) ; steady state: looking for remaining SECTION forms and clauses + (define (finish-section) + (cons (make-section title paragraph* suppressed? (reverse rclause*)) rsection*)) + (parse-top top* + (lambda () (reverse (finish-section))) + (lambda (title paragraph*) (misplaced-grammar-error (car top*))) + (lambda (top* title paragraph* suppressed?) + (s3 top* title paragraph* suppressed? '() (finish-section))) + (lambda (top* clause) + (s3 top* title paragraph* suppressed? (cons clause rclause*) rsection*)))) + (s1 top*))) + (define (go init-nts top* mddir) + (let ([grammar (parse-grammar top*)]) + (let* ([clause* (apply append (map section-clause* (grammar-section* grammar)))] + [terminal-clause* (filter terminal-clause? clause*)] + [binop-clause* (filter binop-clause? clause*)] + [regular-clause* (left-factor (filter regular-clause? clause*))] + [env (make-env terminal-clause* (append binop-clause* regular-clause*))]) + (define (elt-helper x) + (cond + [(sep-elt? x) #`(#,(if (sep-elt-+? x) #'sepby1 #'sepby) #,(elt-helper (sep-elt-elt x)) (sep->parser #,(sep-elt-sep x)))] + [(opt-elt? x) #`(optional #,(elt-helper (opt-elt-elt x)) #,(opt-elt-default x))] + [(kleene-elt? x) #`(#,(if (kleene-elt-+? x) #'many+ #'many) #,(elt-helper (kleene-elt-elt x)))] + [(constant-elt? x) #`(constant->parser '#,(constant-elt-k x))] + [(id-elt? x) (lookup (id-elt-id x) env)] + [else (errorf 'elt-helper "unhandled elt ~s\n" x)])) + (define (binop-helper clause) + #`[#,(clause-id clause) + (infix-expression-parser + #,(map (lambda (level) + (syntax-case level () + [(L/R op1 ... op2) + (or (free-identifier=? #'L/R #'LEFT) (free-identifier=? #'L/R #'RIGHT)) + #`(L/R #,(fold-right (lambda (op next) #`(++ (binop->parser '#,op) #,next)) #'(binop->parser 'op2) #'(op1 ...)))])) + (binop-clause-level* clause)) + #,(elt-helper (binop-clause-term clause)) + #,(binop-clause-receiver clause))]) + (define (nt-helper clause) + #`[#,(clause-id clause) + #,(let f ([prod* (regular-clause-prod* clause)]) + (if (null? prod*) + #'zero + (let ([elt* (production-elt* (car prod*))]) + (with-syntax ([name (production-name (car prod*))] + [(elt ...) elt*] + [receiver (production-receiver (car prod*))]) + (with-syntax ([(x ...) (generate-temporaries elt*)]) + (with-syntax ([([y _] ...) (filter (lambda (pr) (not (constant-elt? (cadr pr)))) #'([x elt] ...))]) + (with-syntax ([(where-nt ...) (map elt-helper elt*)]) + #`(+++ ;; use +++ if you don't ever need to backtrack to a previous production for the same non-terminal + (lambda (inp) + (when (and 'name (grammar-trace)) (printf ">>~s(~a)~%" 'name (format-inp inp))) + (let ([res ((trace-is name (lambda (bfp efp) (receiver bfp efp y ...)) (where [x <- where-nt] ...)) inp)]) + (when (and 'name (grammar-trace)) + (if (stream-null? res) + (printf "<<~s(~a) failed~%" 'name (format-inp inp)) + (printf "<<~s(~a) succeeded~%" 'name (format-inp inp)))) + res)) + #,(f (cdr prod*))))))))))]) + (with-syntax ([(init-nt ...) + (syntax-case init-nts () + [(id1 id2 ...) (andmap identifier? #'(id1 id2 ...)) #'(id1 id2 ...)] + [id (identifier? #'id) (list #'id)])]) + (when mddir + (for-each + (lambda (init-nt) + (let ([mdfn (format "~a/~a.md" mddir (syntax->datum init-nt))]) + (render-markdown init-nt grammar mdfn env))) + #'(init-nt ...))) + (with-syntax ([((lhs rhs) ...) + (append + (map binop-helper binop-clause*) + (map nt-helper regular-clause*))]) + #'(module (init-nt ...) + (module M (init-nt ...) (define lhs rhs) ...) + (define init-nt + (let () + (import M) + (make-top-level-parser init-nt))) + ...)))))) + (syntax-case x (markdown-directory) + [(_ init-nts (markdown-directory mddir) top ...) + (string? (datum mddir)) + (go #'init-nts #'(top ...) (datum mddir))] + [(_ init-nts top ...) (go #'init-nts #'(top ...) #f)]))) (indirect-export define-grammar result @@ -347,6 +748,7 @@ many many+ +++ + infix-expression-parser grammar-trace format-inp diff --git a/mats/examples.ms b/mats/examples.ms index 7235e4bf7e..f92c5d16d5 100644 --- a/mats/examples.ms +++ b/mats/examples.ms @@ -20,7 +20,7 @@ (begin (mat name (begin - (parameterize ((current-directory *examples-directory*)) + (parameterize ((source-directories (cons *examples-directory* (source-directories)))) (load (format "~a/~a.ss" *examples-directory* file)) ...) #t) @@ -588,5 +588,5 @@ edit> (examples-mat ez-grammar-test ("ez-grammar-test") (equal? (with-output-to-string ez-grammar-test) - "end of tests\n") + "8 tests ran\n") ) diff --git a/s/pdhtml.ss b/s/pdhtml.ss index 8980aea277..fd1b1e2210 100644 --- a/s/pdhtml.ss +++ b/s/pdhtml.ss @@ -204,7 +204,7 @@ (let ([entry* (sort (lambda (x y) (or (> (entrydata-bfp x) (entrydata-bfp y)) (and (= (entrydata-bfp x) (entrydata-bfp y)) - (> (entrydata-efp x) (entrydata-efp y))))) + (< (entrydata-efp x) (entrydata-efp y))))) (filedata-entry* fdata))]) #;(assert (not (null? entry*))) (let loop ([entry (car entry*)] [entry* (cdr entry*)] [new-entry* '()]) From 431c1af87f1b5e70c226d775081c419a4dcb7842 Mon Sep 17 00:00:00 2001 From: dyb Date: Thu, 2 Nov 2017 10:37:55 -0400 Subject: [PATCH 6/9] updated CSUG pointer original commit: 93b428e656504852a3efb154217e4f7779d74c1d --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index f5f40f3925..51b62205a4 100644 --- a/README.md +++ b/README.md @@ -48,7 +48,7 @@ The R6RS core of the Chez Scheme language is described in which also includes an introduction to Scheme and a set of example programs. Chez Scheme's additional language, run-time system, and programming environment features are described in the -[Chez Scheme User's Guide](http://cisco.github.io/ChezScheme/csug9.4/csug.html). +[Chez Scheme User's Guide](http://cisco.github.io/ChezScheme/csug9.5/csug.html). The latter includes a shared index and a shared summary of forms, with links where appropriate to the former, so it is often the best starting point. From 893dfe5d352f734b10db5ca8a896f53876b02029 Mon Sep 17 00:00:00 2001 From: dyb Date: Tue, 7 Nov 2017 21:49:08 -0500 Subject: [PATCH 7/9] maybe-compile-{file,program,library} and automatic import compilation now treat a malformed object file as if it were not present and needs to be regenerated. A malformed object file (particularly a truncated one) might occur if the compiling processes is killed or aborts before it has a chance to delete a partial object file. syntax.ss, 7.ms original commit: c2cb8c79a925c0eb2f9d589e3a497712800bd1dc --- LOG | 8 ++++++++ mats/7.ms | 41 +++++++++++++++++++++++++++++++++++++++++ s/syntax.ss | 35 ++++++++++++++++++++++++----------- 3 files changed, 73 insertions(+), 11 deletions(-) diff --git a/LOG b/LOG index 482d5ebbc0..2b92305b49 100644 --- a/LOG +++ b/LOG @@ -744,3 +744,11 @@ mats/examples.ms, examples/ez-grammar.ss, examples/ez-grammar-test.ss, examples/Makefile +- maybe-compile-{file,program,library} and automatic import + compilation now treat a malformed object file as if it were + not present and needs to be regenerated. A malformed object + file (particularly a truncated one) might occur if the compiling + processes is killed or aborts before it has a chance to delete + a partial object file. + syntax.ss, + 7.ms diff --git a/mats/7.ms b/mats/7.ms index aa5b9eddb0..29bba8229c 100644 --- a/mats/7.ms +++ b/mats/7.ms @@ -834,6 +834,47 @@ (begin (rm-rf "testdir") #t) + ; make sure maybe-compile-file handles incomplete fasl files + (begin + (mkfile "testfile-mc-2a.ss" + '(library (testfile-mc-2a) + (export q) + (import (chezscheme)) + (define f + (lambda () + (printf "running f\n") + "x")) + (define-syntax q + (begin + (printf "expanding testfile-mc-2a\n") + (lambda (x) + (printf "expanding q\n") + #'(f)))))) + (mkfile "testfile-mc-2.ss" + '(import (chezscheme) (testfile-mc-2a)) + '(define-syntax qq + (begin + (printf "expanding testfile-mc-2\n") + (lambda (x) + (printf "expanding qq\n") + #'q))) + '(printf "qq => ~a\n" qq)) + (delete-file "testfile-mc-2a.so") + (delete-file "testfile-mc-2.so") + (display-string (separate-compile '(lambda (x) (parameterize ([compile-file-message #f] [compile-imported-libraries #t] [compile-compressed #f]) (maybe-compile-program x))) 'mc-2)) + #t) + (begin + (let ([p (open-file-input/output-port "testfile-mc-2a.so" (file-options no-create no-fail no-truncate))]) + (set-port-length! p 73) + (close-port p)) + (display-string (separate-compile '(lambda (x) (parameterize ([compile-file-message #f] [compile-imported-libraries #t] [compile-compressed #f] [import-notify #t]) (maybe-compile-program x))) 'mc-2)) + #t) + (begin + (let ([p (open-file-input/output-port "testfile-mc-2.so" (file-options no-create no-fail no-truncate))]) + (set-port-length! p 87) + (close-port p)) + (display-string (separate-compile '(lambda (x) (parameterize ([compile-file-message #f] [compile-imported-libraries #t] [compile-compressed #f] [import-notify #t]) (maybe-compile-program x))) 'mc-2)) + #t) ) (mat make-boot-file diff --git a/s/syntax.ss b/s/syntax.ss index 7c1c18568f..bbec064e3a 100644 --- a/s/syntax.ss +++ b/s/syntax.ss @@ -4787,7 +4787,14 @@ found-uid)] [else ($oops #f "re~:[loading~;compiling~] ~a did not define library ~s" compile-file? src-path path)])]) (parameterize ([source-directories (cons (path-parent src-path) (source-directories))]) - ($load-library obj-path (if ct? 'load 'revisit))) + (guard (c [(and (irritants-condition? c) (member obj-path (condition-irritants c))) + (with-message (with-output-to-string + (lambda () + (display-string "failed to load object file: ") + (display-condition c))) + ($oops/c #f ($make-recompile-condition path) + "problem loading object file ~a ~s" obj-path c))]) + ($load-library obj-path (if ct? 'load 'revisit)))) (cond [(search-loaded-libraries path) => (lambda (found-uid) @@ -5193,16 +5200,22 @@ (let ([ofn-mod-time (file-modification-time ofn)]) (if (time>=? ofn-mod-time (with-new-who who (lambda () (file-modification-time ifn)))) (with-message "object file is not older" - (let ([rcinfo* (load-recompile-info who ofn)]) - (if (andmap - (lambda (rcinfo) - (andmap - (lambda (x) - (with-source-path who x - (lambda (x) - (time<=? (with-new-who who (lambda () (file-modification-time x))) ofn-mod-time)))) - (recompile-info-include-req* rcinfo))) - rcinfo*) + (let ([rcinfo* (guard (c [else (with-message (with-output-to-string + (lambda () + (display-string "failed to process object file: ") + (display-condition c))) + #f)]) + (load-recompile-info who ofn))]) + (if (and rcinfo* + (andmap + (lambda (rcinfo) + (andmap + (lambda (x) + (with-source-path who x + (lambda (x) + (time<=? (with-new-who who (lambda () (file-modification-time x))) ofn-mod-time)))) + (recompile-info-include-req* rcinfo))) + rcinfo*)) (if (compile-imported-libraries) (guard (c [(and ($recompile-condition? c) (eq? ($recompile-importer-path c) #f)) (with-message (format "recompiling ~s because a dependency has changed" ifn) From b453ab1582c188cc95b44edb340f93efb3949487 Mon Sep 17 00:00:00 2001 From: dyb Date: Thu, 9 Nov 2017 11:12:34 -0500 Subject: [PATCH 8/9] updated release notes with entry about improved compile times for procedures with large numbers of variables original commit: bc117fd4d567a6863689fec6814882a0f04e577a --- release_notes/release_notes.stex | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/release_notes/release_notes.stex b/release_notes/release_notes.stex index 8721aecdfe..c03d353554 100644 --- a/release_notes/release_notes.stex +++ b/release_notes/release_notes.stex @@ -1760,6 +1760,16 @@ x86\_64 has been fixed. %----------------------------------------------------------------------------- \section{Performance Enhancements}\label{section:performance} +\subsection{Improved compile times (9.5.1)} + +Compile times are now lower, sometimes by an order of magnitude or +more, for procedures with thousands of parameters, local variables, +and compiler-introduced temporaries. +For such procedures, the register/frame allocator proactively spills +variables with large live ranges, cutting down on the size and cost +of building the conflict graph used to represent pairs of variables +that are live at the same time and therefore cannot share a location. + \subsection{Improved oblist management (9.3.3)} As a result of improvements in the handing of the oblist (symbol table), From db1ce365fc60e6e9398e39a5521dc0ca410a0378 Mon Sep 17 00:00:00 2001 From: Bob Burger Date: Wed, 22 Nov 2017 10:38:33 -0500 Subject: [PATCH 9/9] fixed two typos original commit: 2d1d3ad5fcf4b63423d9e7ff783315792ac81626 --- csug/io.stex | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/csug/io.stex b/csug/io.stex index 3c55bd9ef1..8a843c5281 100644 --- a/csug/io.stex +++ b/csug/io.stex @@ -3661,8 +3661,8 @@ the last dot (period) in the last component of a path name. The path root component is the portion of \var{path} that does not include the extension, if any, or the dot that precedes it. -If the first component names a root directory (including drivers -and shared under Windows) or home directory, +If the first component names a root directory (including drives +and shares under Windows) or home directory, \scheme{path-absolute?} returns \scheme{#t}. Otherwise, \scheme{path-absolute?} returns \scheme{#f}.