1 
;;; * Package: C; Log: C.Log *

2 
;;;

3 
;;; **********************************************************************

4 
;;; This code was written as part of the CMU Common Lisp project at

5 
;;; Carnegie Mellon University, and has been placed in the public domain.

6 
;;;

7 
(ext:filecomment

8 
"$Header: /tiger/var/lib/cvsroots/cmucl/src/compiler/ir1opt.lisp,v 1.65.2.7 2000/08/09 12:56:55 dtc Exp $")

9 
;;;

10 
;;; **********************************************************************

11 
;;;

12 
;;; This file implements the IR1 optimization phase of the compiler. IR1

13 
;;; optimization is a grabbag of optimizations that don't make major changes

14 
;;; to the blocklevel control flow and don't use flow analysis. These

15 
;;; optimizations can mostly be classified as "metaevaluation", but there is a

16 
;;; sizable topdown component as well.

17 
;;;

18 
;;; Written by Rob MacLachlan

19 
;;;

20 
(inpackage :c)

21 

22 

23 
;;;; Interface for obtaining results of constant folding:

24 

25 
;;; ConstantContinuationP  Interface

26 
;;;

27 
;;; Return true if the sole use of Cont is a reference to a constant leaf.

28 
;;;

29 
(defun constantcontinuationp (cont)

30 
(declare (type continuation cont) (values boolean))

31 
(let ((use (continuationuse cont)))

32 
(and (refp use)

33 
(constantp (refleaf use)))))

34 

35 

36 
;;; ContinuationValue  Interface

37 
;;;

38 
;;; Return the constant value for a continuation whose only use is a

39 
;;; constant node.

40 
;;;

41 
(defun continuationvalue (cont)

42 
(declare (type continuation cont))

43 
(assert (constantcontinuationp cont))

44 
(constantvalue (refleaf (continuationuse cont))))

45 

46 

47 
;;;; Interface for obtaining results of type inference:

48 

49 
;;; CONTINUATIONPROVENTYPE  Interface

50 
;;;

51 
;;; Return a (possibly values) type that describes what we have proven about

52 
;;; the type of Cont without taking any type assertions into consideration.

53 
;;; This is just the union of the NODEDERIVEDTYPE of all the uses. Most

54 
;;; often people use CONTINUATIONDERIVEDTYPE or CONTINUATIONTYPE instead of

55 
;;; using this function directly.

56 
;;;

57 
(defun continuationproventype (cont)

58 
(declare (type continuation cont))

59 
(ecase (continuationkind cont)

60 
((:blockstart :deletedblockstart)

61 
(let ((uses (blockstartuses (continuationblock cont))))

62 
(if uses

63 
(do ((res (nodederivedtype (first uses))

64 
(valuestypeunion (nodederivedtype (first current))

65 
res))

66 
(current (rest uses) (rest current)))

67 
((null current) res))

68 
*emptytype*)))

69 
(:insideblock

70 
(nodederivedtype (continuationuse cont)))))

71 

72 

73 
;;; ContinuationDerivedType  Interface

74 
;;;

75 
;;; Our best guess for the type of this continuation's value. Note that

76 
;;; this may be Values or Function type, which cannot be passed as an argument

77 
;;; to the normal type operations. See ContinuationType. This may be called

78 
;;; on deleted continuations, always returning *.

79 
;;;

80 
;;; What we do is call CONTINUATIONPROVENTYPE and check whether the result

81 
;;; is a subtype of the assertion. If so, return the proven type and set

82 
;;; TYPECHECK to nil. Otherwise, return the intersection of the asserted and

83 
;;; proven types, and set TYPECHECK T. If TYPECHECK already has a nonnull

84 
;;; value, then preserve it. Only in the somewhat unusual circumstance of

85 
;;; a newly discovered assertion will we change TYPECHECK from NIL to T.

86 
;;;

87 
;;; The result value is cached in the Continuation%DerivedType. If the

88 
;;; slot is true, just return that value, otherwise recompute and stash the

89 
;;; value there.

90 
;;;

91 
(proclaim '(inline continuationderivedtype))

92 
(defun continuationderivedtype (cont)

93 
(declare (type continuation cont))

94 
(or (continuation%derivedtype cont)

95 
(%continuationderivedtype cont)))

96 
;;;

97 
(defun %continuationderivedtype (cont)

98 
(declare (type continuation cont))

99 
(let ((proven (continuationproventype cont))

100 
(asserted (continuationassertedtype cont)))

101 
(cond ((valuessubtypep proven asserted)

102 
(setf (continuation%typecheck cont) nil)

103 
(setf (continuation%derivedtype cont) proven))

104 
(t

105 
(unless (or (continuation%typecheck cont)

106 
(not (continuationdest cont))

107 
(eq asserted *universaltype*))

108 
(setf (continuation%typecheck cont) t))

109 

110 
(setf (continuation%derivedtype cont)

111 
(valuestypeintersection asserted proven))))))

112 

113 

114 
;;; CONTINUATIONTYPECHECK  Interface

115 
;;;

116 
;;; Call CONTINUATIONDERIVEDTYPE to make sure the slot is up to date, then

117 
;;; return it.

118 
;;;

119 
(proclaim '(inline continuationtypecheck))

120 
(defun continuationtypecheck (cont)

121 
(declare (type continuation cont))

122 
(continuationderivedtype cont)

123 
(continuation%typecheck cont))

124 

125 

126 
;;; ContinuationType  Interface

127 
;;;

128 
;;; Return the derived type for Cont's first value. This is guaranteed not

129 
;;; to be a Values or Function type.

130 
;;;

131 
(defun continuationtype (cont)

132 
(declare (type continuation cont) (values ctype))

133 
(singlevaluetype (continuationderivedtype cont)))

134 

135 

136 
;;;; Interface routines used by optimizers:

137 

138 
;;; ReoptimizeContinuation  Interface

139 
;;;

140 
;;; This function is called by optimizers to indicate that something

141 
;;; interesting has happened to the value of Cont. Optimizers must make sure

142 
;;; that they don't call for reoptimization when nothing has happened, since

143 
;;; optimization will fail to terminate.

144 
;;;

145 
;;; We clear any cached type for the continuation and set the reoptimize

146 
;;; flags on everything in sight, unless the continuation is deleted (in which

147 
;;; case we do nothing.)

148 
;;;

149 
;;; Since this can get called curing IR1 conversion, we have to be careful

150 
;;; not to fly into space when the Dest's Prev is missing.

151 
;;;

152 
(defun reoptimizecontinuation (cont)

153 
(declare (type continuation cont))

154 
(unless (member (continuationkind cont) '(:deleted :unused))

155 
(setf (continuation%derivedtype cont) nil)

156 
(let ((dest (continuationdest cont)))

157 
(when dest

158 
(setf (continuationreoptimize cont) t)

159 
(setf (nodereoptimize dest) t)

160 
(let ((prev (nodeprev dest)))

161 
(when prev

162 
(let* ((block (continuationblock prev))

163 
(component (blockcomponent block)))

164 
(when (typep dest 'cif)

165 
(setf (blocktestmodified block) t))

166 
(setf (blockreoptimize block) t)

167 
(setf (componentreoptimize component) t))))))

168 
(douses (node cont)

169 
(setf (blocktypecheck (nodeblock node)) t)))

170 
(undefinedvalue))

171 

172 

173 
;;; DeriveNodeType  Interface

174 
;;;

175 
;;; Annotate Node to indicate that its result has been proven to be typep to

176 
;;; RType. After IR1 conversion has happened, this is the only correct way to

177 
;;; supply information discovered about a node's type. If you fuck with the

178 
;;; NodeDerivedType directly, then information may be lost and reoptimization

179 
;;; may not happen.

180 
;;;

181 
;;; What we do is intersect Rtype with Node's DerivedType. If the

182 
;;; intersection is different from the old type, then we do a

183 
;;; ReoptimizeContinuation on the NodeCont.

184 
;;;

185 
(defun derivenodetype (node rtype)

186 
(declare (type node node) (type ctype rtype))

187 
(let ((nodetype (nodederivedtype node)))

188 
(unless (eq nodetype rtype)

189 
(let ((int (valuestypeintersection nodetype rtype)))

190 
(when (type/= nodetype int)

191 
(when (and *checkconsistency*

192 
(eq int *emptytype*)

193 
(not (eq rtype *emptytype*)))

194 
(let ((*compilererrorcontext* node))

195 
(compilerwarning

196 
"New inferred type ~S conflicts with old type:~

197 
~% ~S~%*** Bug?"

198 
(typespecifier rtype) (typespecifier nodetype))))

199 
(setf (nodederivedtype node) int)

200 
(reoptimizecontinuation (nodecont node))))))

201 
(undefinedvalue))

202 

203 
(declaim (startblock assertcontinuationtype

204 
assertcontinuationoptionaltype assertcalltype))

205 

206 
;;; AssertContinuationType  Interface

207 
;;;

208 
;;; Similar to DeriveNodeType, but asserts that it is an error for Cont's

209 
;;; value not to be typep to Type. If we improve the assertion, we set

210 
;;; TYPECHECK and TYPEASSERTED to guarantee that the new assertion will be

211 
;;; checked.

212 
;;;

213 
(defun assertcontinuationtype (cont type)

214 
(declare (type continuation cont) (type ctype type))

215 
(let ((conttype (continuationassertedtype cont)))

216 
(unless (eq conttype type)

217 
(let ((int (valuestypeintersection conttype type)))

218 
(when (type/= conttype int)

219 
(setf (continuationassertedtype cont) int)

220 
(douses (node cont)

221 
(setf (blockattributep (blockflags (nodeblock node))

222 
typecheck typeasserted)

223 
t))

224 
(reoptimizecontinuation cont)))))

225 
(undefinedvalue))

226 

227 

228 
;;; Assertcontinuationoptionaltype  Interface

229 
;;;

230 
;;; Similar to AssertContinuationType, but asserts that the type is

231 
;;; for an optional argument and that other arguments may be received.

232 
;;;

233 
(defun assertcontinuationoptionaltype (cont type)

234 
(declare (type continuation cont) (type ctype type))

235 
(let ((opttype (makevaluestype :optional (list type)

236 
:rest *universaltype*)))

237 
(assertcontinuationtype cont opttype)))

238 

239 

240 
;;; AssertCallType  Interface

241 
;;;

242 
;;; Assert that Call is to a function of the specified Type. It is assumed

243 
;;; that the call is legal and has only constants in the keyword positions.

244 
;;;

245 
(defun assertcalltype (call type)

246 
(declare (type combination call) (type functiontype type))

247 
(derivenodetype call (functiontypereturns type))

248 
(let ((args (combinationargs call)))

249 
(dolist (req (functiontyperequired type))

250 
(when (null args) (returnfrom assertcalltype))

251 
(let ((arg (pop args)))

252 
(assertcontinuationoptionaltype arg req)))

253 
(dolist (opt (functiontypeoptional type))

254 
(when (null args) (returnfrom assertcalltype))

255 
(let ((arg (pop args)))

256 
(assertcontinuationoptionaltype arg opt)))

257 

258 
(let ((rest (functiontyperest type)))

259 
(when rest

260 
(dolist (arg args)

261 
(assertcontinuationoptionaltype arg rest))))

262 

263 
(dolist (key (functiontypekeywords type))

264 
(let ((name (keyinfoname key)))

265 
(do ((arg args (cddr arg)))

266 
((null arg))

267 
(when (eq (continuationvalue (first arg)) name)

268 
(assertcontinuationoptionaltype

269 
(second arg) (keyinfotype key)))))))

270 
(undefinedvalue))

271 

272 

273 
;;;; IR1OPTIMIZE:

274 

275 
(declaim (startblock ir1optimize))

276 

277 
;;; IR1Optimize  Interface

278 
;;;

279 
;;; Do one forward pass over Component, deleting unreachable blocks and

280 
;;; doing IR1 optimizations. We can ignore all blocks that don't have the

281 
;;; Reoptimize flag set. If ComponentReoptimize is true when we are done,

282 
;;; then another iteration would be beneficial.

283 
;;;

284 
;;; We delete blocks when there is either no predecessor or the block is in

285 
;;; a lambda that has been deleted. These blocks would eventually be deleted

286 
;;; by DFO recomputation, but doing it here immediately makes the effect

287 
;;; avaliable to IR1 optimization.

288 
;;;

289 
(defun ir1optimize (component)

290 
(declare (type component component))

291 
(setf (componentreoptimize component) nil)

292 
(doblocks (block component)

293 
(cond

294 
((or (blockdeletep block)

295 
(null (blockpred block))

296 
(eq (functionalkind (blockhomelambda block)) :deleted))

297 
(deleteblock block))

298 
(t

299 
(loop

300 
(let ((succ (blocksucc block)))

301 
(unless (and succ (null (rest succ)))

302 
(return)))

303 

304 
(let ((last (blocklast block)))

305 
(typecase last

306 
(cif

307 
(flushdest (iftest last))

308 
(when (unlinknode last) (return)))

309 
(exit

310 
(when (maybedeleteexit last) (return)))))

311 

312 
(unless (joinsuccessorifpossible block)

313 
(return)))

314 

315 
(when (and (blockreoptimize block) (blockcomponent block))

316 
(assert (not (blockdeletep block)))

317 
(ir1optimizeblock block))

318 

319 
(when (and (blockflushp block) (blockcomponent block))

320 
(assert (not (blockdeletep block)))

321 
(flushdeadcode block)))))

322 

323 
(undefinedvalue))

324 

325 

326 
;;; IR1OptimizeBlock  Internal

327 
;;;

328 
;;; Loop over the nodes in Block, looking for stuff that needs to be

329 
;;; optimized. We dispatch off of the type of each node with its reoptimize

330 
;;; flag set:

331 
;;;  With a combination, we call PropagateFunctionChange whenever the

332 
;;; function changes, and call IR1OptimizeCombination if any argument

333 
;;; changes.

334 
;;;  With an Exit, we derive the node's type from the Value's type. We don't

335 
;;; propagate Cont's assertion to the Value, since if we did, this would

336 
;;; move the checking of Cont's assertion to the exit. This wouldn't work

337 
;;; with Catch and UWP, where the Exit node is just a placeholder for the

338 
;;; actual unknown exit.

339 
;;;

340 
;;; Note that we clear the node & block reoptimize flags *before* doing the

341 
;;; optimization. This ensures that the node or block will be reoptimized if

342 
;;; necessary. We leave the NODEOPTIMIZE flag set going into

343 
;;; IR1OPTIMIZERETURN, since it wants to clear the flag itself.

344 
;;;

345 
(defun ir1optimizeblock (block)

346 
(declare (type cblock block))

347 
(setf (blockreoptimize block) nil)

348 
(donodes (node cont block :restartp t)

349 
(when (nodereoptimize node)

350 
(setf (nodereoptimize node) nil)

351 
(typecase node

352 
(ref)

353 
(combination

354 
(ir1optimizecombination node))

355 
(cif

356 
(ir1optimizeif node))

357 
(creturn

358 
(setf (nodereoptimize node) t)

359 
(ir1optimizereturn node))

360 
(mvcombination

361 
(ir1optimizemvcombination node))

362 
(exit

363 
(let ((value (exitvalue node)))

364 
(when value

365 
(derivenodetype node (continuationderivedtype value)))))

366 
(cset

367 
(ir1optimizeset node)))))

368 
(undefinedvalue))

369 

370 

371 
;;; JoinSuccessorIfPossible  Internal

372 
;;;

373 
;;; We cannot combine with a successor block if:

374 
;;; 1] The successor has more than one predecessor.

375 
;;; 2] The last node's Cont is also used somewhere else.

376 
;;; 3] The successor is the current block (infinite loop).

377 
;;; 4] The next block has a different cleanup, and thus we may want to insert

378 
;;; cleanup code between the two blocks at some point.

379 
;;; 5] The next block has a different home lambda, and thus the control

380 
;;; transfer is a nonlocal exit.

381 
;;;

382 
;;; If we succeed, we return true, otherwise false.

383 
;;;

384 
;;; Joining is easy when the successor's Start continuation is the same from

385 
;;; our Last's Cont. If they differ, then we can still join when the last

386 
;;; continuation has no next and the next continuation has no uses. In this

387 
;;; case, we replace the next continuation with the last before joining the

388 
;;; blocks.

389 
;;;

390 
(defun joinsuccessorifpossible (block)

391 
(declare (type cblock block))

392 
(let ((next (first (blocksucc block))))

393 
(when (blockstart next)

394 
(let* ((last (blocklast block))

395 
(lastcont (nodecont last))

396 
(nextcont (blockstart next)))

397 
(cond ((or (rest (blockpred next))

398 
(not (eq (continuationuse lastcont) last))

399 
(eq next block)

400 
(not (eq (blockendcleanup block)

401 
(blockstartcleanup next)))

402 
(not (eq (blockhomelambda block)

403 
(blockhomelambda next))))

404 
nil)

405 
((eq lastcont nextcont)

406 
(joinblocks block next)

407 
t)

408 
((and (null (blockstartuses next))

409 
(eq (continuationkind lastcont) :insideblock))

410 
(let ((nextnode (continuationnext nextcont)))

411 
;;

412 
;; If nextcont does have a dest, it must be unreachable,

413 
;; since there are no uses. DELETECONTINUATION will mark the

414 
;; dest block as deletep [and also this block, unless it is

415 
;; no longer backward reachable from the dest block.]

416 
(deletecontinuation nextcont)

417 
(setf (nodeprev nextnode) lastcont)

418 
(setf (continuationnext lastcont) nextnode)

419 
(setf (blockstart next) lastcont)

420 
(joinblocks block next))

421 
t)

422 
(t

423 
nil))))))

424 

425 

426 
;;; JoinBlocks  Internal

427 
;;;

428 
;;; Join together two blocks which have the same ending/starting

429 
;;; continuation. The code in Block2 is moved into Block1 and Block2 is

430 
;;; deleted from the DFO. We combine the optimize flags for the two blocks so

431 
;;; that any indicated optimization gets done.

432 
;;;

433 
(defun joinblocks (block1 block2)

434 
(declare (type cblock block1 block2))

435 
(let* ((last (blocklast block2))

436 
(lastcont (nodecont last))

437 
(succ (blocksucc block2))

438 
(start2 (blockstart block2)))

439 
(do ((cont start2 (nodecont (continuationnext cont))))

440 
((eq cont lastcont)

441 
(when (eq (continuationkind lastcont) :insideblock)

442 
(setf (continuationblock lastcont) block1)))

443 
(setf (continuationblock cont) block1))

444 

445 
(unlinkblocks block1 block2)

446 
(dolist (block succ)

447 
(unlinkblocks block2 block)

448 
(linkblocks block1 block))

449 

450 
(setf (blocklast block1) last)

451 
(setf (continuationkind start2) :insideblock))

452 

453 
(setf (blockflags block1)

454 
(attributesunion (blockflags block1)

455 
(blockflags block2)

456 
(blockattributes typeasserted testmodified)))

457 

458 
(let ((next (blocknext block2))

459 
(prev (blockprev block2)))

460 
(setf (blocknext prev) next)

461 
(setf (blockprev next) prev))

462 

463 
(undefinedvalue))

464 

465 
;;; FlushDeadCode  Internal

466 
;;;

467 
;;; Delete any nodes in Block whose value is unused and have no

468 
;;; sideeffects. We can delete sets of lexical variables when the set

469 
;;; variable has no references.

470 
;;;

471 
;;; [### For now, don't delete potentially flushable calls when they have the

472 
;;; Call attribute. Someday we should look at the funcitonal args to determine

473 
;;; if they have any sideeffects.]

474 
;;;

475 
(defun flushdeadcode (block)

476 
(declare (type cblock block))

477 
(donodesbackwards (node cont block)

478 
(unless (continuationdest cont)

479 
(typecase node

480 
(ref

481 
(deleteref node)

482 
(unlinknode node))

483 
(combination

484 
(let ((info (combinationkind node)))

485 
(when (functioninfop info)

486 
(let ((attr (functioninfoattributes info)))

487 
(when (and (ir1attributep attr flushable)

488 
(not (ir1attributep attr call)))

489 
(flushdest (combinationfun node))

490 
(dolist (arg (combinationargs node))

491 
(flushdest arg))

492 
(unlinknode node))))))

493 
(mvcombination

494 
(when (eq (basiccombinationkind node) :local)

495 
(let ((fun (combinationlambda node)))

496 
(when (dolist (var (lambdavars fun) t)

497 
(when (or (leafrefs var)

498 
(lambdavarsets var))

499 
(return nil)))

500 
(flushdest (first (basiccombinationargs node)))

501 
(deletelet fun)))))

502 
(exit

503 
(let ((value (exitvalue node)))

504 
(when value

505 
(flushdest value)

506 
(setf (exitvalue node) nil))))

507 
(cset

508 
(let ((var (setvar node)))

509 
(when (and (lambdavarp var)

510 
(null (leafrefs var)))

511 
(flushdest (setvalue node))

512 
(setf (basicvarsets var)

513 
(delete node (basicvarsets var)))

514 
(unlinknode node)))))))

515 

516 
(setf (blockflushp block) nil)

517 
(undefinedvalue))

518 

519 
(declaim (endblock))

520 

521 

522 
;;;; Local call return type propagation:

523 

524 
;;; FindResultType  Internal

525 
;;;

526 
;;; This function is called on RETURN nodes that have their REOPTIMIZE flag

527 
;;; set. It iterates over the uses of the RESULT, looking for interesting

528 
;;; stuff to update the TAILSET. If a use isn't a local call, then we union

529 
;;; its type together with the types of other such uses. We assign to the

530 
;;; RETURNRESULTTYPE the intersection of this type with the RESULT's asserted

531 
;;; type. We can make this intersection now (potentially before type checking)

532 
;;; because this assertion on the result will eventually be checked (if

533 
;;; appropriate.)

534 
;;;

535 
;;; We call MAYBECONVERTTAILLOCALCALL on each local nonMV combination,

536 
;;; which may change the succesor of the call to be the called function, and if

537 
;;; so, checks if the call can become an assignment. If we convert to an

538 
;;; assignment, we abort, since the RETURN has been deleted.

539 
;;;

540 
(defun findresulttype (node)

541 
(declare (type creturn node))

542 
(let ((result (returnresult node)))

543 
(collect ((useunion *emptytype* valuestypeunion))

544 
(douses (use result)

545 
(cond ((and (basiccombinationp use)

546 
(eq (basiccombinationkind use) :local))

547 
(assert (eq (lambdatailset (nodehomelambda use))

548 
(lambdatailset (combinationlambda use))))

549 
(when (combinationp use)

550 
(when (nthvalue 1 (maybeconverttaillocalcall use))

551 
(returnfrom findresulttype (undefinedvalue)))))

552 
(t

553 
(useunion (nodederivedtype use)))))

554 
(let ((int (valuestypeintersection (continuationassertedtype result)

555 
(useunion))))

556 
(setf (returnresulttype node) int))))

557 
(undefinedvalue))

558 

559 

560 
;;; IR1OptimizeReturn  Internal

561 
;;;

562 
;;; Do stuff to realize that something has changed about the value delivered

563 
;;; to a return node. Since we consider the return values of all functions in

564 
;;; the tail set to be equivalent, this amounts to bringing the entire tail set

565 
;;; up to date. We iterate over the returns for all the functions in the tail

566 
;;; set, reanalyzing them all (not treating Node specially.)

567 
;;;

568 
;;; When we are done, we check if the new type is different from the old

569 
;;; TAILSETTYPE. If so, we set the type and also reoptimize all the

570 
;;; continuations for references to functions in the tail set. This will

571 
;;; cause IR1OPTIMIZECOMBINATION to derive the new type as the results of the

572 
;;; calls.

573 
;;;

574 
(defun ir1optimizereturn (node)

575 
(declare (type creturn node))

576 
(let* ((tails (lambdatailset (returnlambda node)))

577 
(funs (tailsetfunctions tails)))

578 
(collect ((res *emptytype* valuestypeunion))

579 
(dolist (fun funs)

580 
(let ((return (lambdareturn fun)))

581 
(when return

582 
(when (nodereoptimize return)

583 
(setf (nodereoptimize return) nil)

584 
(findresulttype return))

585 
(res (returnresulttype return)))))

586 

587 
(when (type/= (res) (tailsettype tails))

588 
(setf (tailsettype tails) (res))

589 
(dolist (fun (tailsetfunctions tails))

590 
(dolist (ref (leafrefs fun))

591 
(reoptimizecontinuation (nodecont ref)))))))

592 

593 
(undefinedvalue))

594 

595 

596 
;;; IF optimization:

597 

598 
(declaim (startblock ir1optimizeif))

599 

600 
;;; IR1OptimizeIf  Internal

601 
;;;

602 
;;; If the test has multiple uses, replicate the node when possible. Also

603 
;;; check if the predicate is known to be true or false, deleting the IF node

604 
;;; in favor of the appropriate branch when this is the case.

605 
;;;

606 
(defun ir1optimizeif (node)

607 
(declare (type cif node))

608 
(let ((test (iftest node))

609 
(block (nodeblock node)))

610 

611 
(when (and (eq (blockstart block) test)

612 
(eq (continuationnext test) node)

613 
(rest (blockstartuses block)))

614 
(douses (use test)

615 
(when (immediatelyusedp test use)

616 
(convertifif use node)

617 
(when (continuationuse test) (return)))))

618 

619 
(let* ((type (continuationtype test))

620 
(victim

621 
(cond ((constantcontinuationp test)

622 
(if (continuationvalue test)

623 
(ifalternative node)

624 
(ifconsequent node)))

625 
((not (typesintersect type *nulltype*))

626 
(ifalternative node))

627 
((type= type *nulltype*)

628 
(ifconsequent node)))))

629 
(when victim

630 
(flushdest test)

631 
(when (rest (blocksucc block))

632 
(unlinkblocks block victim))

633 
(setf (componentreanalyze (blockcomponent (nodeblock node))) t)

634 
(unlinknode node))))

635 
(undefinedvalue))

636 

637 

638 
;;; ConvertIfIf  Internal

639 
;;;

640 
;;; Create a new copy of an IF Node that tests the value of the node Use.

641 
;;; The test must have >1 use, and must be immediately used by Use. Node must

642 
;;; be the only node in its block (implying that blockstart = iftest).

643 
;;;

644 
;;; This optimization has an effect semantically similar to the

645 
;;; sourcetosource transformation:

646 
;;; (IF (IF A B C) D E) ==>

647 
;;; (IF A (IF B D E) (IF C D E))

648 
;;;

649 
;;; We clobber the NODESOURCEPATH of both the original and the new node so

650 
;;; that dead code deletion notes will definitely not consider either node to

651 
;;; be part of the original source. One node might become unreachable,

652 
;;; resulting in a spurious note.

653 
;;;

654 
(defun convertifif (use node)

655 
(declare (type node use) (type cif node))

656 
(withir1environment node

657 
(let* ((block (nodeblock node))

658 
(test (iftest node))

659 
(cblock (ifconsequent node))

660 
(ablock (ifalternative node))

661 
(useblock (nodeblock use))

662 
(dummycont (makecontinuation))

663 
(newcont (makecontinuation))

664 
(newnode (makeif :test newcont

665 
:consequent cblock :alternative ablock))

666 
(newblock (continuationstartsblock newcont)))

667 
(prevlink newnode newcont)

668 
(setf (continuationdest newcont) newnode)

669 
(addcontinuationuse newnode dummycont)

670 
(setf (blocklast newblock) newnode)

671 

672 
(unlinkblocks useblock block)

673 
(deletecontinuationuse use)

674 
(addcontinuationuse use newcont)

675 
(linkblocks useblock newblock)

676 

677 
(linkblocks newblock cblock)

678 
(linkblocks newblock ablock)

679 

680 
(push "<IF Duplication>" (nodesourcepath node))

681 
(push "<IF Duplication>" (nodesourcepath newnode))

682 

683 
(reoptimizecontinuation test)

684 
(reoptimizecontinuation newcont)

685 
(setf (componentreanalyze *currentcomponent*) t)))

686 
(undefinedvalue))

687 

688 
(declaim (endblock))

689 

690 

691 
;;;; Exit IR1 optimization:

692 

693 
;;; MaybeDeleteExit  Interface

694 
;;;

695 
;;; This function attempts to delete an exit node, returning true if it

696 
;;; deletes the block as a consequence:

697 
;;;  If the exit is degenerate (has no Entry), then we don't do anything,

698 
;;; since there is nothing to be done.

699 
;;;  If the exit node and its Entry have the same home lambda then we know

700 
;;; the exit is local, and can delete the exit. We change uses of the

701 
;;; ExitValue to be uses of the original continuation, then unlink the

702 
;;; node. If the exit is to a TR context, then we must do MERGETAILSETS

703 
;;; on any local calls which delivered their value to this exit.

704 
;;;  If there is no value (as in a GO), then we skip the value semantics.

705 
;;;

706 
;;; This function is also called by environment analysis, since it wants all

707 
;;; exits to be optimized even if normal optimization was omitted.

708 
;;;

709 
(defun maybedeleteexit (node)

710 
(declare (type exit node))

711 
(let ((value (exitvalue node))

712 
(entry (exitentry node))

713 
(cont (nodecont node)))

714 
(when (and entry

715 
(eq (nodehomelambda node) (nodehomelambda entry)))

716 
(setf (entryexits entry) (delete node (entryexits entry)))

717 
(prog1

718 
(unlinknode node)

719 
(when value

720 
(collect ((merges))

721 
(when (returnp (continuationdest cont))

722 
(douses (use value)

723 
(when (and (basiccombinationp use)

724 
(eq (basiccombinationkind use) :local))

725 
(merges use))))

726 
(substitutecontinuationuses cont value)

727 
(dolist (merge (merges))

728 
(mergetailsets merge))))))))

729 

730 

731 
;;;; Combination IR1 optimization:

732 

733 
(declaim (startblock ir1optimizecombination maybeterminateblock

734 
validatecalltype))

735 

736 
;;; Ir1OptimizeCombination  Internal

737 
;;;

738 
;;; Do IR1 optimizations on a Combination node.

739 
;;;

740 
(defun ir1optimizecombination (node)

741 
(declare (type combination node))

742 
(when (continuationreoptimize (basiccombinationfun node))

743 
(propagatefunctionchange node))

744 
(let ((args (basiccombinationargs node))

745 
(kind (basiccombinationkind node)))

746 
(case kind

747 
(:local

748 
(let ((fun (combinationlambda node)))

749 
(if (eq (functionalkind fun) :let)

750 
(propagateletargs node fun)

751 
(propagatelocalcallargs node fun))))

752 
((:full :error)

753 
(dolist (arg args)

754 
(when arg

755 
(setf (continuationreoptimize arg) nil))))

756 
(t

757 
(dolist (arg args)

758 
(when arg

759 
(setf (continuationreoptimize arg) nil)))

760 

761 
(let ((attr (functioninfoattributes kind)))

762 
(when (and (ir1attributep attr foldable)

763 
(not (ir1attributep attr call))

764 
(every #'constantcontinuationp args)

765 
(continuationdest (nodecont node)))

766 
(constantfoldcall node)

767 
(returnfrom ir1optimizecombination)))

768 

769 
(let ((fun (functioninfoderivetype kind)))

770 
(when fun

771 
(let ((res (funcall fun node)))

772 
(when res

773 
(derivenodetype node res)

774 
(maybeterminateblock node nil)))))

775 

776 
(let ((fun (functioninfooptimizer kind)))

777 
(unless (and fun (funcall fun node))

778 
(dolist (x (functioninfotransforms kind))

779 
(unless (ir1transform node x)

780 
(return))))))))

781 

782 
(undefinedvalue))

783 

784 

785 
;;; MAYBETERMINATEBLOCK  Interface

786 
;;;

787 
;;; If Call is to a function that doesn't return (type NIL), then terminate

788 
;;; the block there, and link it to the component tail. We also change the

789 
;;; call's CONT to be a dummy continuation to prevent the use from confusing

790 
;;; things.

791 
;;;

792 
;;; Except when called during IR1, we delete the continuation if it has no

793 
;;; other uses. (If it does have other uses, we reoptimize.)

794 
;;;

795 
;;; Termination on the basis of a continuation type assertion is inhibited

796 
;;; when:

797 
;;;  The continuation is deleted (hence the assertion is spurious), or

798 
;;;  We are in IR1 conversion (where THE assertions are subject to

799 
;;; weakening.)

800 
;;;

801 
(defun maybeterminateblock (call ir1p)

802 
(declare (type basiccombination call))

803 
(let* ((block (nodeblock call))

804 
(cont (nodecont call))

805 
(tail (componenttail (blockcomponent block)))

806 
(succ (first (blocksucc block))))

807 
(unless (or (and (eq call (blocklast block)) (eq succ tail))

808 
(blockdeletep block)

809 
*convertingforinterpreter*)

810 
(when (or (and (eq (continuationassertedtype cont) *emptytype*)

811 
(not (or ir1p (eq (continuationkind cont) :deleted))))

812 
(eq (nodederivedtype call) *emptytype*))

813 
(cond (ir1p

814 
(deletecontinuationuse call)

815 
(cond

816 
((blocklast block)

817 
(assert (and (eq (blocklast block) call)

818 
(eq (continuationkind cont) :blockstart))))

819 
(t

820 
(setf (blocklast block) call)

821 
(linkblocks block (continuationstartsblock cont)))))

822 
(t

823 
(nodeendsblock call)

824 
(deletecontinuationuse call)

825 
(if (eq (continuationkind cont) :unused)

826 
(deletecontinuation cont)

827 
(reoptimizecontinuation cont))))

828 

829 
(unlinkblocks block (first (blocksucc block)))

830 
(setf (componentreanalyze (blockcomponent block)) t)

831 
(assert (not (blocksucc block)))

832 
(linkblocks block tail)

833 
(addcontinuationuse call (makecontinuation))

834 
t))))

835 

836 

837 
;;; RecognizeKnownCall  Interface

838 
;;;

839 
;;; Called both by IR1 conversion and IR1 optimization when they have

840 
;;; verified the type signature for the call, and are wondering if something

841 
;;; should be done to specialcase the call. If Call is a call to a global

842 
;;; function, then see if it defined or known:

843 
;;;  If a DEFINEDFUNCTION should be inline expanded, then convert the

844 
;;; expansion and change the call to call it. Expansion is enabled if

845 
;;; :INLINE or if space=0. If the FUNCTIONAL slot is true, we never expand,

846 
;;; since this function has already been converted. Local call analysis

847 
;;; will duplicate the definition if necessary. We claim that the parent

848 
;;; form is LABELS for context declarations, since we don't want it to be

849 
;;; considered a real global function.

850 
;;;  In addition to a direct check for the function name in the table, we

851 
;;; also must check for slot accessors. If the function is a slot accessor,

852 
;;; then we set the combination kind to the function info of %SlotSetter or

853 
;;; %SlotAccessor, as appropriate.

854 
;;;  If it is a known function, mark it as such by setting the Kind.

855 
;;;

856 
;;; We return the leaf referenced (NIL if not a leaf) and the functioninfo

857 
;;; assigned.

858 
;;;

859 
(defun recognizeknowncall (call ir1p)

860 
(declare (type combination call))

861 
(let* ((ref (continuationuse (basiccombinationfun call)))

862 
(leaf (when (refp ref) (refleaf ref)))

863 
(inlinep (if (and (definedfunctionp leaf)

864 
(not (bytecompiling)))

865 
(definedfunctioninlinep leaf)

866 
:nochance)))

867 
(cond

868 
((eq inlinep :notinline) (values nil nil))

869 
((not (and (globalvarp leaf)

870 
(eq (globalvarkind leaf) :globalfunction)))

871 
(values leaf nil))

872 
((and (ecase inlinep

873 
(:inline t)

874 
(:nochance nil)

875 
((nil :maybeinline) (policy call (zerop space))))

876 
(definedfunctioninlineexpansion leaf)

877 
(let ((fun (definedfunctionfunctional leaf)))

878 
(or (not fun)

879 
(and (eq inlinep :inline) (functionalkind fun))))

880 
(inlineexpansionok call))

881 
(flet ((frob ()

882 
(let ((res (ir1convertlambdafordefun

883 
(definedfunctioninlineexpansion leaf)

884 
leaf t

885 
#'ir1convertinlinelambda

886 
'labels)))

887 
(setf (definedfunctionfunctional leaf) res)

888 
(changerefleaf ref res))))

889 
(if ir1p

890 
(frob)

891 
(withir1environment call

892 
(frob)

893 
(localcallanalyze *currentcomponent*))))

894 

895 
(values (refleaf (continuationuse (basiccombinationfun call)))

896 
nil))

897 
(t

898 
(let* ((name (leafname leaf))

899 
(info (info function info

900 
(if (slotaccessorp leaf)

901 
(if (consp name)

902 
'%slotsetter

903 
'%slotaccessor)

904 
name))))

905 
(if info

906 
(values leaf (setf (basiccombinationkind call) info))

907 
(values leaf nil)))))))

908 

909 

910 
;;; VALIDATECALLTYPE  Internal

911 
;;;

912 
;;; Check if Call satisfies Type. If so, apply the type to the call, and do

913 
;;; MAYBETERMINATEBLOCK and return the values of RECOGNIZEKNOWNCALL. If an

914 
;;; error, set the combination kind and return NIL, NIL. If the type is just

915 
;;; FUNCTION, then skip the syntax check, arg/result type processing, but still

916 
;;; call RECOGNIZEKNOWNCALL, since the call might be to a known lambda, and

917 
;;; that checking is done by local call analysis.

918 
;;;

919 
(defun validatecalltype (call type ir1p)

920 
(declare (type combination call) (type ctype type))

921 
(cond ((not (functiontypep type))

922 
(assert (multiplevaluebind

923 
(val win)

924 
(csubtypep type (specifiertype 'function))

925 
(or val (not win))))

926 
(recognizeknowncall call ir1p))

927 
((validfunctionuse call type

928 
:argumenttest #'alwayssubtypep

929 
:resulttest #'alwayssubtypep

930 
:errorfunction #'compilerwarning

931 
:warningfunction #'compilernote)

932 
(assertcalltype call type)

933 
(maybeterminateblock call ir1p)

934 
(recognizeknowncall call ir1p))

935 
(t

936 
(setf (combinationkind call) :error)

937 
(values nil nil))))

938 

939 

940 
;;; PropagateFunctionChange  Internal

941 
;;;

942 
;;; Called by Ir1Optimize when the function for a call has changed.

943 
;;; If the call is local, we try to letconvert it, and derive the result type.

944 
;;; If it is a :FULL call, we validate it against the type, which recognizes

945 
;;; known calls, does inline expansion, etc. If a call to a predicate in a

946 
;;; nonconditional position or to a function with a source transform, then we

947 
;;; reconvert the form to give IR1 another chance.

948 
;;;

949 
(defun propagatefunctionchange (call)

950 
(declare (type combination call))

951 
(let ((*compilererrorcontext* call)

952 
(funcont (basiccombinationfun call)))

953 
(setf (continuationreoptimize funcont) nil)

954 
(case (combinationkind call)

955 
(:local

956 
(let ((fun (combinationlambda call)))

957 
(maybeletconvert fun)

958 
(unless (member (functionalkind fun) '(:let :assignment :deleted))

959 
(derivenodetype call (tailsettype (lambdatailset fun))))))

960 
(:full

961 
(multiplevaluebind

962 
(leaf info)

963 
(validatecalltype call (continuationtype funcont) nil)

964 
(cond ((functionalp leaf)

965 
(convertcallifpossible

966 
(continuationuse (basiccombinationfun call))

967 
call))

968 
((not leaf))

969 
((or (info function sourcetransform (leafname leaf))

970 
(and info

971 
(ir1attributep (functioninfoattributes info)

972 
predicate)

973 
(let ((dest (continuationdest (nodecont call))))

974 
(and dest (not (ifp dest))))))

975 
(let ((name (leafname leaf)))

976 
(when (symbolp name)

977 
(let ((dums (loop repeat (length (combinationargs call))

978 
collect (gensym))))

979 
(transformcall call

980 
`(lambda ,dums

981 
(,name ,@dums))))))))))))

982 
(undefinedvalue))

983 

984 

985 
;;;; Known function optimization:

986 

987 

988 
;;; RECORDOPTIMIZATIONFAILURE  Internal

989 
;;;

990 
;;; Add a failed optimization note to FAILEDOPTIMZATIONS for Node, Fun

991 
;;; and Args. If there is already a note for Node and Transform, replace it,

992 
;;; otherwise add a new one.

993 
;;;

994 
(defun recordoptimizationfailure (node transform args)

995 
(declare (type combination node) (type transform transform)

996 
(type (or functiontype list) args))

997 
(let* ((table (componentfailedoptimizations *compilecomponent*))

998 
(found (assoc transform (gethash node table))))

999 
(if found

1000 
(setf (cdr found) args)

1001 
(push (cons transform args) (gethash node table))))

1002 
(undefinedvalue))

1003 

1004 

1005 
;;; IR1Transform  Internal

1006 
;;;

1007 
;;; Attempt to transform Node using Function, subject to the call type

1008 
;;; constraint Type. If we are inhibited from doing the transform for some

1009 
;;; reason and Flame is true, then we make a note of the message in

1010 
;;; FAILEDOPTIMIZATIONS for IR1 finalize to pick up. We return true if

1011 
;;; the transform failed, and thus further transformation should be

1012 
;;; attempted. We return false if either the transform suceeded or was

1013 
;;; aborted.

1014 
;;;

1015 
(defun ir1transform (node transform)

1016 
(declare (type combination node) (type transform transform))

1017 
(let* ((type (transformtype transform))

1018 
(fun (transformfunction transform))

1019 
(constrained (functiontypep type))

1020 
(table (componentfailedoptimizations *compilecomponent*))

1021 
(flame

1022 
(if (transformimportant transform)

1023 
(policy node (>= speed brevity))

1024 
(policy node (> speed brevity))))

1025 
(*compilererrorcontext* node))

1026 
(cond ((let ((when (transformwhen transform)))

1027 
(not (or (eq when :both)

1028 
(eq when (if *bytecompiling* :byte :native)))))

1029 
t)

1030 
((or (not constrained)

1031 
(validfunctionuse node type :strictresult t))

1032 
(multiplevaluebind

1033 
(severity args)

1034 
(catch 'giveup

1035 
(transformcall node (funcall fun node))

1036 
(values :none nil))

1037 
(ecase severity

1038 
(:none

1039 
(remhash node table)

1040 
nil)

1041 
(:aborted

1042 
(setf (combinationkind node) :error)

1043 
(when args

1044 
(apply #'compilerwarning args))

1045 
(remhash node table)

1046 
nil)

1047 
(:failure

1048 
(if args

1049 
(when flame

1050 
(recordoptimizationfailure node transform args))

1051 
(setf (gethash node table)

1052 
(remove transform (gethash node table) :key #'car)))

1053 
t)

1054 
(:delayed

1055 
(remhash node table)

1056 
nil))))

1057 
((and flame

1058 
(validfunctionuse node type

1059 
:argumenttest #'typesintersect

1060 
:resulttest #'valuestypesintersect))

1061 
(recordoptimizationfailure node transform type)

1062 
t)

1063 
(t

1064 
t))))

1065 

1066 
(declaim (endblock))

1067 

1068 
;;; giveup, aborttransform  Interface

1069 
;;;

1070 
;;; Just throw the severity and args...

1071 
;;;

1072 
(defun giveup (&rest args)

1073 
"This function is used to throw out of an IR1 transform, aborting this

1074 
attempt to transform the call, but admitting the possibility that this or

1075 
some other transform will later suceed. If arguments are supplied, they are

1076 
format arguments for an efficiency note."

1077 
(values nil)

1078 
(throw 'giveup (values :failure args)))

1079 
;;;

1080 
(defun aborttransform (&rest args)

1081 
"This function is used to throw out of an IR1 transform and force a normal

1082 
call to the function at run time. No further optimizations will be

1083 
attempted."

1084 
(throw 'giveup (values :aborted args)))

1085 

1086 
(defvar *delayedtransforms*)

1087 

1088 
;;; delaytransform  Interface

1089 
;;;

1090 
(defun delaytransform (node &rest reasons)

1091 
"This function is used to throw out of an IR1 transform, and delay the

1092 
transform on the node until later. The reasons specifies when the transform

1093 
will be later retried. The :optimize reason causes the transform to be

1094 
delayed until after the current IR1 optimization pass. The :constraint

1095 
reason causes the transform to be delayed until after constraint

1096 
propagation."

1097 
(let ((assoc (assoc node *delayedtransforms*)))

1098 
(cond ((not assoc)

1099 
(setf *delayedtransforms*

1100 
(acons node reasons *delayedtransforms*))

1101 
(throw 'giveup :delayed))

1102 
((cdr assoc)

1103 
(dolist (reason reasons)

1104 
(pushnew reason (cdr assoc)))

1105 
(throw 'giveup :delayed)))))

1106 

1107 
;;; retrydelayedtransforms  Interface.

1108 
;;;

1109 
;;; Clear any delayed transform with no reasons  these should have been tried

1110 
;;; in the last pass. Then remove the reason from the delayed transform

1111 
;;; reasons, and if any become empty then set reoptimize flags for the

1112 
;;; node. Returns true if any transforms are to be retried.

1113 
;;;

1114 
(defun retrydelayedtransforms (reason)

1115 
(setf *delayedtransforms* (removeifnot #'cdr *delayedtransforms*))

1116 
(let ((reoptimize nil))

1117 
(dolist (assoc *delayedtransforms*)

1118 
(let ((reasons (remove reason (cdr assoc))))

1119 
(setf (cdr assoc) reasons)

1120 
(unless reasons

1121 
(let ((node (car assoc)))

1122 
(unless (nodedeleted node)

1123 
(setf reoptimize t)

1124 
(setf (nodereoptimize node) t)

1125 
(let ((block (nodeblock node)))

1126 
(setf (blockreoptimize block) t)

1127 
(setf (componentreoptimize (blockcomponent block)) t)))))))

1128 
reoptimize))

1129 

1130 

1131 
;;; TransformCall  Internal

1132 
;;;

1133 
;;; Take the lambdaexpression Res, IR1 convert it in the proper

1134 
;;; environment, and then install it as the function for the call Node. We do

1135 
;;; local call analysis so that the new function is integrated into the control

1136 
;;; flow.

1137 
;;;

1138 
(defun transformcall (node res)

1139 
(declare (type combination node) (list res))

1140 
(withir1environment node

1141 
(let ((newfun (ir1convertinlinelambda res))

1142 
(ref (continuationuse (combinationfun node))))

1143 
(changerefleaf ref newfun)

1144 
(setf (combinationkind node) :full)

1145 
(localcallanalyze *currentcomponent*)))

1146 
(undefinedvalue))

1147 

1148 

1149 
;;; ConstantFoldCall  Internal

1150 
;;;

1151 
;;; Replace a call to a foldable function of constant arguments with the

1152 
;;; result of evaluating the form. We insert the resulting constant node after

1153 
;;; the call, stealing the call's continuation. We give the call a

1154 
;;; continuation with no Dest, which should cause it and its arguments to go

1155 
;;; away. If there is an error during the evaluation, we give a warning and

1156 
;;; leave the call alone, making the call a :ERROR call.

1157 
;;;

1158 
;;; If there is more than one value, then we transform the call into a

1159 
;;; values form.

1160 
;;;

1161 
(defun constantfoldcall (call)

1162 
(declare (type combination call))

1163 
(let* ((args (mapcar #'continuationvalue (combinationargs call)))

1164 
(ref (continuationuse (combinationfun call)))

1165 
(fun (leafname (refleaf ref))))

1166 

1167 
(multiplevaluebind (values win)

1168 
(carefulcall fun args call "constant folding")

1169 
(cond

1170 
((not win)

1171 
(setf (combinationkind call) :error))

1172 
;; X Always transform the call below so that nonflushable

1173 
;; functions get flushed if the constant folding works.

1174 
#+nil

1175 
((= (length values) 1)

1176 
(withir1environment call

1177 
(when (producingfaslfile)

1178 
(maybeemitmakeloadforms (first values)))

1179 
(let* ((leaf (findconstant (first values)))

1180 
(node (makeref (leaftype leaf) leaf))

1181 
(dummy (makecontinuation))

1182 
(cont (nodecont call))

1183 
(block (nodeblock call))

1184 
(next (continuationnext cont)))

1185 
(push node (leafrefs leaf))

1186 
(setf (leafeverused leaf) t)

1187 

1188 
(deletecontinuationuse call)

1189 
(addcontinuationuse call dummy)

1190 
(prevlink node dummy)

1191 
(addcontinuationuse node cont)

1192 
(setf (continuationnext cont) next)

1193 
(when (eq call (blocklast block))

1194 
(setf (blocklast block) node))

1195 
(reoptimizecontinuation cont))))

1196 
(t

1197 
(let ((dummies (loop repeat (length args)

1198 
collect (gensym))))

1199 
(transformcall

1200 
call

1201 
`(lambda ,dummies

1202 
(declare (ignore ,@dummies))

1203 
(values ,@(mapcar #'(lambda (x) `',x) values)))))))))

1204 

1205 
(undefinedvalue))

1206 

1207 

1208 
;;;; Local call optimization:

1209 

1210 
(declaim (startblock ir1optimizeset constantreferencep deletelet

1211 
propagateletargs propagatelocalcallargs

1212 
propagatetorefs propagatefromsets

1213 
ir1optimizemvcombination))

1214 

1215 
;;; PropagateToRefs  Internal

1216 
;;;

1217 
;;; Propagate Type to Leaf and its Refs, marking things changed. If the

1218 
;;; leaf type is a function type, then just leave it alone, since TYPE is never

1219 
;;; going to be more specific than that (and TYPEINTERSECTION would choke.)

1220 
;;;

1221 
(defun propagatetorefs (leaf type)

1222 
(declare (type leaf leaf) (type ctype type))

1223 
(let ((vartype (leaftype leaf)))

1224 
(unless (functiontypep vartype)

1225 
(let ((int (typeintersection vartype type)))

1226 
(when (type/= int vartype)

1227 
(setf (leaftype leaf) int)

1228 
(dolist (ref (leafrefs leaf))

1229 
(derivenodetype ref int))))

1230 
(undefinedvalue))))

1231 

1232 

1233 
;;; PROPAGATEFROMSETS  Internal

1234 
;;;

1235 
;;; Figure out the type of a LET variable that has sets. We compute the

1236 
;;; union of the initial value Type and the types of all the set values and to

1237 
;;; a PROPAGATETOREFS with this type.

1238 
;;;

1239 
(defun propagatefromsets (var type)

1240 
(collect ((res type typeunion))

1241 
(dolist (set (basicvarsets var))

1242 
(res (continuationtype (setvalue set)))

1243 
(setf (nodereoptimize set) nil))

1244 
(propagatetorefs var (res)))

1245 
(undefinedvalue))

1246 

1247 

1248 
;;; IR1OPTIMIZESET  Internal

1249 
;;;

1250 
;;; If a let variable, find the initial value's type and do

1251 
;;; PROPAGATEFROMSETS. We also derive the VALUE's type as the node's type.

1252 
;;;

1253 
(defun ir1optimizeset (node)

1254 
(declare (type cset node))

1255 
(let ((var (setvar node)))

1256 
(when (and (lambdavarp var) (leafrefs var))

1257 
(let ((home (lambdavarhome var)))

1258 
(when (eq (functionalkind home) :let)

1259 
(let ((iv (letvarinitialvalue var)))

1260 
(setf (continuationreoptimize iv) nil)

1261 
(propagatefromsets var (continuationtype iv)))))))

1262 

1263 
(derivenodetype node (continuationtype (setvalue node)))

1264 
(undefinedvalue))

1265 

1266 

1267 
;;; CONSTANTREFERENCEP  Interface

1268 
;;;

1269 
;;; Return true if the value of Ref will always be the same (and is thus

1270 
;;; legal to substitute.)

1271 
;;;

1272 
(defun constantreferencep (ref)

1273 
(declare (type ref ref))

1274 
(let ((leaf (refleaf ref)))

1275 
(typecase leaf

1276 
((or constant functional) t)

1277 
(lambdavar

1278 
(null (lambdavarsets leaf)))

1279 
(definedfunction

1280 
(not (eq (definedfunctioninlinep leaf) :notinline)))

1281 
(globalvar

1282 
(case (globalvarkind leaf)

1283 
(:globalfunction t)

1284 
(:constant t))))))

1285 

1286 

1287 
;;; SUBSTITUTESINGLEUSECONTINUATION  Internal

1288 
;;;

1289 
;;; If we have a nonset let var with a single use, then (if possible)

1290 
;;; replace the variable reference's CONT with the arg continuation. This is

1291 
;;; inhibited when:

1292 
;;;  CONT has other uses, or

1293 
;;;  CONT receives multiple values, or

1294 
;;;  the reference is in a different environment from the variable, or

1295 
;;;  either continuation has a funky TYPECHECK annotation.

1296 
;;;  the continuations have incompatible assertions, so the new asserted type

1297 
;;; would be NIL.

1298 
;;;  CONT's assertion is incompatbile with the proven type of ARG's, such as

1299 
;;; when ARG returns multiple values and CONT has a single value assertion.

1300 
;;;  the var's DEST has a different policy than the ARG's (think safety).

1301 
;;;

1302 
;;; We change the Ref to be a reference to NIL with unused value, and let it

1303 
;;; be flushed as dead code. A sideeffect of this substitution is to delete

1304 
;;; the variable.

1305 
;;;

1306 
(defun substitutesingleusecontinuation (arg var)

1307 
(declare (type continuation arg) (type lambdavar var))

1308 
(let* ((ref (first (leafrefs var)))

1309 
(cont (nodecont ref))

1310 
(contatype (continuationassertedtype cont))

1311 
(dest (continuationdest cont)))

1312 
(when (and (eq (continuationuse cont) ref)

1313 
dest

1314 
(not (typep dest '(or creturn exit mvcombination)))

1315 
(eq (nodehomelambda ref)

1316 
(lambdahome (lambdavarhome var)))

1317 
(member (continuationtypecheck arg) '(t nil))

1318 
(member (continuationtypecheck cont) '(t nil))

1319 
(not (eq (valuestypeintersection

1320 
contatype (continuationassertedtype arg))

1321 
*emptytype*))

1322 
(not (eq (valuestypeintersection

1323 
contatype (continuationproventype arg))

1324 
*emptytype*))

1325 
(eq (lexenvcookie (nodelexenv dest))

1326 
(lexenvcookie (nodelexenv (continuationdest arg)))))

1327 
(assert (member (continuationkind arg)

1328 
'(:blockstart :deletedblockstart :insideblock)))

1329 
(assertcontinuationtype arg contatype)

1330 
(setf (nodederivedtype ref) *wildtype*)

1331 
(changerefleaf ref (findconstant nil))

1332 
(substitutecontinuation arg cont)

1333 
(reoptimizecontinuation arg)

1334 
t)))

1335 

1336 

1337 
;;; DELETELET  Interface

1338 
;;;

1339 
;;; Delete a Let, removing the call and bind nodes, and warning about any

1340 
;;; unreferenced variables. Note that FLUSHDEADCODE will come along right

1341 
;;; away and delete the REF and then the lambda, since we flush the FUN

1342 
;;; continuation.

1343 
;;;

1344 
(defun deletelet (fun)

1345 
(declare (type clambda fun))

1346 
(assert (member (functionalkind fun) '(:let :mvlet)))

1347 
(noteunreferencedvars fun)

1348 
(let ((call (letcombination fun)))

1349 
(flushdest (basiccombinationfun call))

1350 
(unlinknode call)

1351 
(unlinknode (lambdabind fun))

1352 
(setf (lambdabind fun) nil))

1353 
(undefinedvalue))

1354 

1355 

1356 
;;; PropagateLetArgs  Internal

1357 
;;;

1358 
;;; This function is called when one of the arguments to a LET changes. We

1359 
;;; look at each changed argument. If the corresponding variable is set, then

1360 
;;; we call PROPAGATEFROMSETS. Otherwise, we consider substituting for the

1361 
;;; variable, and also propagate derivedtype information for the arg to all

1362 
;;; the Var's refs.

1363 
;;;

1364 
;;; Substitution is inhibited when the arg leaf's derived type isn't a

1365 
;;; subtype of the argument's asserted type. This prevents type checking from

1366 
;;; being defeated, and also ensures that the best representation for the

1367 
;;; variable can be used.

1368 
;;;

1369 
;;; Substitution of individual references is inhibited if the reference is

1370 
;;; in a different component from the home. This can only happen with closures

1371 
;;; over toplevel lambda vars. In such cases, the references may have already

1372 
;;; been compiled, and thus can't be retroactively modified.

1373 
;;;

1374 
;;; If all of the variables are deleted (have no references or sets) when

1375 
;;; we are done, then we delete the let.

1376 
;;;

1377 
;;; Note that we are responsible for clearing the ContinuationReoptimize

1378 
;;; flags.

1379 
;;;

1380 
(defun propagateletargs (call fun)

1381 
(declare (type combination call) (type clambda fun))

1382 
(loop for arg in (combinationargs call)

1383 
and var in (lambdavars fun) do

1384 
(when (and arg (continuationreoptimize arg))

1385 
(setf (continuationreoptimize arg) nil)

1386 
(cond

1387 
((lambdavarsets var)

1388 
(propagatefromsets var (continuationtype arg)))

1389 
((let ((use (continuationuse arg)))

1390 
(when (refp use)

1391 
(let ((leaf (refleaf use)))

1392 
(when (and (constantreferencep use)

1393 
(valuessubtypep (leaftype leaf)

1394 
(continuationassertedtype arg)))

1395 
(propagatetorefs var (continuationtype arg))

1396 
(let ((thiscomp (blockcomponent (nodeblock use))))

1397 
(substituteleafif

1398 
#'(lambda (ref)

1399 
(cond ((eq (blockcomponent (nodeblock ref))

1400 
thiscomp)

1401 
t)

1402 
(t

1403 
(assert (eq (functionalkind (lambdahome fun))

1404 
:toplevel))

1405 
nil)))

1406 
leaf var))

1407 
t)))))

1408 
((and (null (rest (leafrefs var)))

1409 
(not *bytecompiling*)

1410 
(substitutesingleusecontinuation arg var)))

1411 
(t

1412 
(propagatetorefs var (continuationtype arg))))))

1413 

1414 
(when (and (every #'null (combinationargs call))

1415 
(notany #'lambdavarsets (lambdavars fun)))

1416 
(deletelet fun))

1417 

1418 
(undefinedvalue))

1419 

1420 

1421 
;;; PropagateLocalCallArgs  Internal

1422 
;;;

1423 
;;; This function is called when one of the args to a nonlet local call

1424 
;;; changes. For each changed argument corresponding to an unset variable, we

1425 
;;; compute the union of the types across all calls and propagate this type

1426 
;;; information to the var's refs.

1427 
;;;

1428 
;;; If the function has an XEP, then we don't do anything, since we won't

1429 
;;; discover anything.

1430 
;;;

1431 
;;; We can clear the ContinuationReoptimize flags for arguments in all calls

1432 
;;; corresponding to changed arguments in Call, since the only use in IR1

1433 
;;; optimization of the Reoptimize flag for local call args is right here.

1434 
;;;

1435 
(defun propagatelocalcallargs (call fun)

1436 
(declare (type combination call) (type clambda fun))

1437 

1438 
(unless (or (functionalentryfunction fun)

1439 
(lambdaoptionaldispatch fun))

1440 
(let* ((vars (lambdavars fun))

1441 
(union (mapcar #'(lambda (arg var)

1442 
(when (and arg

1443 
(continuationreoptimize arg)

1444 
(null (basicvarsets var)))

1445 
(continuationtype arg)))

1446 
(basiccombinationargs call)

1447 
vars))

1448 
(thisref (continuationuse (basiccombinationfun call))))

1449 

1450 
(dolist (arg (basiccombinationargs call))

1451 
(when arg

1452 
(setf (continuationreoptimize arg) nil)))

1453 

1454 
(dolist (ref (leafrefs fun))

1455 
(let ((dest (continuationdest (nodecont ref))))

1456 
(unless (or (eq ref thisref) (not dest))

1457 
(setq union

1458 
(mapcar #'(lambda (thisarg old)

1459 
(when old

1460 
(setf (continuationreoptimize thisarg) nil)

1461 
(typeunion (continuationtype thisarg) old)))

1462 
(basiccombinationargs dest)

1463 
union)))))

1464 

1465 
(mapc #'(lambda (var type)

1466 
(when type

1467 
(propagatetorefs var type)))

1468 
vars union)))

1469 

1470 
(undefinedvalue))

1471 

1472 
(declaim (endblock))

1473 

1474 

1475 
;;;; Multiple values optimization:

1476 

1477 
;;; IR1OPTIMIZEMVCOMBINATION  Internal

1478 
;;;

1479 
;;; Do stuff to notice a change to a MV combination node. There are two

1480 
;;; main branches here:

1481 
;;;  If the call is local, then it is already a MV let, or should become one.

1482 
;;; Note that although all :LOCAL MV calls must eventually be converted to

1483 
;;; :MVLETs, there can be a window when the call is local, but has not

1484 
;;; been let converted yet. This is because the entrypoint lambdas may

1485 
;;; have stray references (in other entry points) that have not been

1486 
;;; deleted yet.

1487 
;;;  The call is full. This case is somewhat similar to the nonMV

1488 
;;; combination optimization: we propagate return type information and

1489 
;;; notice nonreturning calls. We also have an optimization

1490 
;;; which tries to convert MVCALLs into MVbinds.

1491 
;;;

1492 
(defun ir1optimizemvcombination (node)

1493 
(ecase (basiccombinationkind node)

1494 
(:local

1495 
(let ((funcont (basiccombinationfun node)))

1496 
(when (continuationreoptimize funcont)

1497 
(setf (continuationreoptimize funcont) nil)

1498 
(maybeletconvert (combinationlambda node))))

1499 
(setf (continuationreoptimize (first (basiccombinationargs node))) nil)

1500 
(when (eq (functionalkind (combinationlambda node)) :mvlet)

1501 
(unless (convertmvbindtolet node)

1502 
(ir1optimizemvbind node))))

1503 
(:full

1504 
(let* ((fun (basiccombinationfun node))

1505 
(funchanged (continuationreoptimize fun))

1506 
(args (basiccombinationargs node)))

1507 
(when funchanged

1508 
(setf (continuationreoptimize fun) nil)

1509 
(let ((type (continuationtype fun)))

1510 
(when (functiontypep type)

1511 
(derivenodetype node (functiontypereturns type))))

1512 
(maybeterminateblock node nil)

1513 
(let ((use (continuationuse fun)))

1514 
(when (and (refp use) (functionalp (refleaf use)))

1515 
(convertcallifpossible use node)

1516 
(when (eq (basiccombinationkind node) :local)

1517 
(maybeletconvert (refleaf use))))))

1518 
(unless (or (eq (basiccombinationkind node) :local)

1519 
(eq (continuationfunctionname fun) '%throw))

1520 
(ir1optimizemvcall node))

1521 
(dolist (arg args)

1522 
(setf (continuationreoptimize arg) nil))))

1523 
(:error))

1524 
(undefinedvalue))

1525 

1526 

1527 
;;; Valuestypesdefaulted  Internal

1528 
;;;

1529 
;;; Like valuestypes, but returns the types of the given number of

1530 
;;; arguments. If optional of rest values must be used then the union

1531 
;;; with the null type is computed in case of defaulting, and if no

1532 
;;; values are available then they are defaulted to the null type.

1533 
;;;

1534 
(defun valuestypesdefaulted (type count)

1535 
(declare (type ctype type) (type index count))

1536 
(cond ((eq type *wildtype*)

1537 
(let ((types nil))

1538 
(dotimes (i count types)

1539 
(push *universaltype* types))))

1540 
((not (valuestypep type))

1541 
(let ((types nil))

1542 
(dotimes (i (1 count))

1543 
(push *nulltype* types))

1544 
(push type types)))

1545 
(t

1546 
(let ((required (argstyperequired type))

1547 
(optional (argstypeoptional type))

1548 
(keypallowp (or (argstypekeyp type) (argstypeallowp type)))

1549 
(rest (argstyperest type)))

1550 
(collect ((types))

1551 
(dotimes (i count)

1552 
(types (cond (required (singlevaluetype (pop required)))

1553 
(optional (valuestypeunion

1554 
(singlevaluetype (pop optional))

1555 
*nulltype*))

1556 
(keypallowp *universaltype*)

1557 
(rest (valuestypeunion (singlevaluetype rest)

1558 
*nulltype*))

1559 
(t *nulltype*))))

1560 
(types))))))

1561 

1562 

1563 
;;; IR1OPTIMIZEMVBIND  Internal

1564 
;;;

1565 
;;; Propagate derived type info from the values continuation to the vars.

1566 
;;;

1567 
(defun ir1optimizemvbind (node)

1568 
(declare (type mvcombination node))

1569 
(let ((arg (first (basiccombinationargs node)))

1570 
(vars (lambdavars (combinationlambda node))))

1571 
(let ((types (valuestypesdefaulted (continuationderivedtype arg)

1572 
(length vars))))

1573 
(mapc #'(lambda (var type)

1574 
(if (basicvarsets var)

1575 
(propagatefromsets var type)

1576 
(propagatetorefs var type)))

1577 
vars types))

1578 

1579 
(setf (continuationreoptimize arg) nil))

1580 
(undefinedvalue))

1581 

1582 

1583 
;;; IR1OPTIMIZEMVCALL  Internal

1584 
;;;

1585 
;;; If possible, convert a general MV call to an MVBIND. We can do this

1586 
;;; if:

1587 
;;;  The call has only one argument, and

1588 
;;;  The function has a known fixed number of arguments, or

1589 
;;;  The argument yields a known fixed number of values.

1590 
;;;

1591 
;;; What we do is change the function in the MVCALL to be a lambda that "looks

1592 
;;; like an MV bind", which allows IR1OPTIMIZEMVCOMBINATION to notice that

1593 
;;; this call can be converted (the next time around.) This new lambda just

1594 
;;; calls the actual function with the MVBIND variables as arguments. Note

1595 
;;; that this new MV bind is not letconverted immediately, as there are going

1596 
;;; to be stray references from the entrypoint functions until they get

1597 
;;; deleted.

1598 
;;;

1599 
;;; In order to avoid loss of argument count checking, we only do the

1600 
;;; transformation according to a known number of expected argument if safety

1601 
;;; is unimportant. We can always convert if we know the number of actual

1602 
;;; values, since the normal call that we build will still do any appropriate

1603 
;;; argument count checking.

1604 
;;;

1605 
;;; We only attempt the transformation if the called function is a constant

1606 
;;; reference. This allows us to just splice the leaf into the new function,

1607 
;;; instead of trying to somehow bind the function expression. The leaf must

1608 
;;; be constant because we are evaluating it again in a different place. This

1609 
;;; also has the effect of squelching multiple warnings when there is an

1610 
;;; argument count error.

1611 
;;;

1612 
(defun ir1optimizemvcall (node)

1613 
(let ((fun (basiccombinationfun node))

1614 
(*compilererrorcontext* node)

1615 
(ref (continuationuse (basiccombinationfun node)))

1616 
(args (basiccombinationargs node)))

1617 

1618 
(unless (and (refp ref) (constantreferencep ref)

1619 
args (null (rest args)))

1620 
(returnfrom ir1optimizemvcall))

1621 

1622 
(multiplevaluebind (min max)

1623 
(functiontypenargs (continuationtype fun))

1624 
(let ((totalnvals

1625 
(multiplevaluebind

1626 
(types nvals)

1627 
(valuestypes (continuationderivedtype (first args)))

1628 
(declare (ignore types))

1629 
(if (eq nvals :unknown) nil nvals))))

1630 

1631 
(when totalnvals

1632 
(when (and min (< totalnvals min))

1633 
(compilerwarning

1634 
"MULTIPLEVALUECALL with ~R values when the function expects ~

1635 
at least ~R."

1636 
totalnvals min)

1637 
(setf (basiccombinationkind node) :error)

1638 
(returnfrom ir1optimizemvcall))

1639 
(when (and max (> totalnvals max))

1640 
(compilerwarning

1641 
"MULTIPLEVALUECALL with ~R values when the function expects ~

1642 
at most ~R."

1643 
totalnvals max)

1644 
(setf (basiccombinationkind node) :error)

1645 
(returnfrom ir1optimizemvcall)))

1646 

1647 
(let ((count (cond (totalnvals)

1648 
((and (policy node (zerop safety)) (eql min max))

1649 
min)

1650 
(t nil))))

1651 
(when count

1652 
(withir1environment node

1653 
(let* ((dums (loop repeat count collect (gensym)))

1654 
(ignore (gensym))

1655 
(fun (ir1convertlambda

1656 
`(lambda (&optional ,@dums &rest ,ignore)

1657 
(declare (ignore ,ignore))

1658 
(funcall ,(refleaf ref) ,@dums)))))

1659 
(changerefleaf ref fun)

1660 
(assert (eq (basiccombinationkind node) :full))

1661 
(localcallanalyze *currentcomponent*)

1662 
(assert (eq (basiccombinationkind node) :local)))))))))

1663 
(undefinedvalue))

1664 

1665 

1666 
;;; CONVERTMVBINDTOLET  Internal

1667 
;;;

1668 
;;; If we see:

1669 
;;; (multiplevaluebind (x y)

1670 
;;; (values xx yy)

1671 
;;; ...)

1672 
;;; Convert to:

1673 
;;; (let ((x xx)

1674 
;;; (y yy))

1675 
;;; ...)

1676 
;;;

1677 
;;; What we actually do is convert the VALUES combination into a normal let

1678 
;;; combination calling the original :MVLET lambda. If there are extra args to

1679 
;;; VALUES, discard the corresponding continuations. If there are insufficient

1680 
;;; args, insert references to NIL.

1681 
;;;

1682 
(defun convertmvbindtolet (call)

1683 
(declare (type mvcombination call))

1684 
(let* ((arg (first (basiccombinationargs call)))

1685 
(use (continuationuse arg)))

1686 
(when (and (combinationp use)

1687 
(eq (continuationfunctionname (combinationfun use))

1688 
'values))

1689 
(let* ((fun (combinationlambda call))

1690 
(vars (lambdavars fun))

1691 
(vals (combinationargs use))

1692 
(nvars (length vars))

1693 
(nvals (length vals)))

1694 
(cond ((> nvals nvars)

1695 
(mapc #'flushdest (subseq vals nvars))

1696 
(setq vals (subseq vals 0 nvars)))

1697 
((< nvals nvars)

1698 
(withir1environment use

1699 
(let ((nodeprev (nodeprev use)))

1700 
(setf (nodeprev use) nil)

1701 
(setf (continuationnext nodeprev) nil)

1702 
(collect ((res vals))

1703 
(loop as cont = (makecontinuation use)

1704 
and prev = nodeprev then cont

1705 
repeat ( nvars nvals)

1706 
do (referenceconstant prev cont nil)

1707 
(res cont))

1708 
(setq vals (res)))

1709 
(prevlink use (car (last vals)))))))

1710 
(setf (combinationargs use) vals)

1711 
(flushdest (combinationfun use))

1712 
(let ((funcont (basiccombinationfun call)))

1713 
(setf (continuationdest funcont) use)

1714 
(setf (combinationfun use) funcont))

1715 
(setf (combinationkind use) :local)

1716 
(setf (functionalkind fun) :let)

1717 
(flushdest (first (basiccombinationargs call)))

1718 
(unlinknode call)

1719 
(when vals

1720 
(reoptimizecontinuation (first vals)))

1721 
(propagatetoargs use fun))

1722 
t)))

1723 

1724 

1725 
;;; VALUESLIST IR1 optimizer  Internal

1726 
;;;

1727 
;;; If we see:

1728 
;;; (valueslist (list x y z))

1729 
;;;

1730 
;;; Convert to:

1731 
;;; (values x y z)

1732 
;;;

1733 
;;; In implementation, this is somewhat similar to CONVERTMVBINDTOLET. We

1734 
;;; grab the args of LIST and make them args of the VALUESLIST call, flushing

1735 
;;; the old argument continuation (allowing the LIST to be flushed.)

1736 
;;;

1737 
(defoptimizer (valueslist optimizer) ((list) node)

1738 
(let ((use (continuationuse list)))

1739 
(when (and (combinationp use)

1740 
(eq (continuationfunctionname (combinationfun use))

1741 
'list))

1742 
(changerefleaf (continuationuse (combinationfun node))

1743 
(findfreefunction 'values "in a strange place"))

1744 
(setf (combinationkind node) :full)

1745 
(let ((args (combinationargs use)))

1746 
(dolist (arg args)

1747 
(setf (continuationdest arg) node))

1748 
(setf (combinationargs use) nil)

1749 
(flushdest list)

1750 
(setf (combinationargs node) args))

1751 
t)))

1752 

1753 

1754 
;;; VALUES IR1 transform  Internal

1755 
;;;

1756 
;;; If VALUES appears in a nonMV context, then effectively convert it to a

1757 
;;; PROG1. This allows the computation of the additional values to become dead

1758 
;;; code. Some attempt is made to correct the node derived type, setting it to

1759 
;;; the received singlevaluetype. The node continuation asserted type must

1760 
;;; also be adjusted, taking care when the continuation has multiple uses.

1761 
;;;

1762 
(deftransform values ((&rest vals) * * :node node)

1763 
(let ((cont (nodecont node)))

1764 
(when (typep (continuationdest cont) '(or creturn exit mvcombination))

1765 
(giveup))

1766 
(flet ((firstvaluetype (type)

1767 
(declare (type ctype type))

1768 
(cond ((valuestypep type)

1769 
(let ((required (argstyperequired type)))

1770 
(if required

1771 
(first required)

1772 
(let ((otype (argstypeoptional type)))

1773 
(cond (otype (first otype))

1774 
((or (argstypekeyp type)

1775 
(argstypeallowp type))

1776 
*universaltype*)

1777 
((argstyperest type))

1778 
(t *nulltype*))))))

1779 
((eq type *wildtype*)

1780 
*universaltype*)

1781 
(t

1782 
type))))

1783 
(cond ((= (length (finduses cont)) 1)

1784 
(setf (nodederivedtype node)

1785 
(singlevaluetype (nodederivedtype node)))

1786 
(setf (continuationassertedtype cont)

1787 
(firstvaluetype (continuationassertedtype cont))))

1788 
(t

1789 
(setf (nodederivedtype node)

1790 
(singlevaluetype (nodederivedtype node)))

1791 
(setf (continuationassertedtype cont)

1792 
(valuestypeunion (continuationassertedtype cont)

1793 
(firstvaluetype

1794 
(continuationassertedtype cont)))))))

1795 
(reoptimizecontinuation cont)

1796 
(if vals

1797 
(let ((dummies (loop repeat (1 (length vals))

1798 
collect (gensym))))

1799 
`(lambda (val ,@dummies)

1800 
(declare (ignore ,@dummies))

1801 
val))

1802 
'nil)))
