diff options
Diffstat (limited to 'src/interp')
| -rw-r--r-- | src/interp/compiler.boot | 41 | ||||
| -rw-r--r-- | src/interp/g-opt.boot | 7 |
2 files changed, 32 insertions, 16 deletions
diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot index a297b448..5aa9e6cb 100644 --- a/src/interp/compiler.boot +++ b/src/interp/compiler.boot @@ -1757,25 +1757,40 @@ compRetractAlternative(x,t,stmt,m,s,T) == -- convertible to t (using only courtesy coerciions) or that -- `y' is retractable to t. -- - -- 1. Evaluate the retract condition. + -- 1. Evaluate the retract condition, and retract. y := T.expr -- guaranteed to be a name. e := T.env - [caseCode,caseMode,e,envFalse] := - compBoolean(["case",y,t],$Boolean,e) or return - stackAndThrow('"%1 is not retractable to %2",[s,t]) - -- 2. Evaluate the actual retraction to `t'. - -- We try courtesy coercions first, then `retract'. That way - -- we can use optimized versions where available. That also - -- makes the scheme works for untagged unions. - [restrictCode,.,e] := tryCourtesyCoercion([y,T.mode,e],t) or - comp(["retract",y],t,e) or return nil - -- 3. Now declare `x'. + caseCode := nil + restrictCode := nil + envFalse := e + -- 1.1. Try courtesy coercions first. That way we can use + -- optimized versions where available. That also + -- makes the scheme work for untagged unions. + if testT := compBoolean(["case",y,t],$Boolean,e) then + [caseCode,.,e,envFalse] := testT + [restrictCode,.,e] := + tryCourtesyCoercion([y,T.mode,e],t) or + comp(["retract",y],t,e) or return + stackAndThrow('"Could not retract %1 to type %2bp",[s,t]) + -- 1.2. Otherwise try retractIfCan, for those `% has RetractableTo t'. + else if retractT := comp(["retractIfCan",y],["Union",t,'"failed"],e) then + [retractCode,.,e] := retractT + -- Assign this value to a temporary. From the backend point of + -- view, that temporary needs to have a lifetime that covers both + -- the condition and the body of the alternative, so just use + -- assignment here and let the rest of the compiler deal with it. + z := GENSYM() + caseCode := ["PROGN",["%LET",z,retractCode],["QEQCAR",z,0]] + restrictCode := ["QCDR",z] + -- 1.3. Everything else failed; nice try. + else return stackAndThrow('"%1 is not retractable to %2bp",[s,t]) + -- 2. Now declare `x'. [.,.,e] := compMakeDeclaration([":",x,t],$EmptyMode,e) or return nil e := put(x,"value",[genSomeVariable(),t,e],e) - -- 4. Compile body of the retract pattern. + -- 3. Compile body of the retract pattern. stmtT := comp(stmt,m,e) or return stackAndThrow('"could not compile %1b under mode %2pb",[stmt,m]) - -- 5. Generate code for the whole pattern. + -- 4. Generate code for the whole pattern. code := [caseCode, ["LET",[[x,restrictCode]],stmtT.expr]] [code,stmtT.mode,stmtT.env,envFalse] diff --git a/src/interp/g-opt.boot b/src/interp/g-opt.boot index 2b194c76..30e253f2 100644 --- a/src/interp/g-opt.boot +++ b/src/interp/g-opt.boot @@ -380,8 +380,8 @@ optEQ u == u $simpleVMoperators == - '(CONS CAR CDR LENGTH SIZE EQUAL EQL EQ - INTEGERP FLOATP STRINGP IDENTP SYMBOLP) + '(CONS CAR CDR LENGTH SIZE EQUAL EQL EQ NOT NULL OR AND + QEQCAR QCDR QCAR INTEGERP FLOATP STRINGP IDENTP SYMBOLP) isSimpleVMForm form == isAtomicForm form => true @@ -423,13 +423,14 @@ optLET u == substPairs := [[var,:init] for [var,init] in inits] for clauses in tails args while continue repeat clause := first clauses - -- we do not attempt more complicate clauses yet. + -- we do not attempt more complicated clauses yet. clause isnt [test,stmt] => continue := false -- Stop inlining at least one test is not simple not isSimpleVMForm test => continue := false rplac(first clause,SUBLIS(substPairs,test)) isSimpleVMForm stmt => rplac(second clause,SUBLIS(substPairs,stmt)) + continue := false continue => body u not MEMQ(op,$simpleVMoperators) => u |