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

2 
;;;

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

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

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

6 
;;; If you want to use this code or any part of Spice Lisp, please contact

7 
;;; Scott Fahlman (FAHLMAN@CMUC).

8 
;;; **********************************************************************

9 
;;;

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

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

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

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

14 
;;; sizable topdown component as well.

15 
;;;

16 
;;; Written by Rob MacLachlan

17 
;;;

18 
(inpackage 'c)

19 

20 
;;;

21 
;;; A hashtable from combination nodes to things describing how an

22 
;;; optimization of the node failed. If the thing is a list, then it is format

23 
;;; arguments. If it is a type, then the type is a type that the call failed

24 
;;; to match.

25 
;;;

26 
(defvar *failedoptimizations* (makehashtable :test #'eq))

27 

28 

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

30 

31 
;;; ConstantContinuationP  Interface

32 
;;;

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

34 
;;;

35 
(proclaim '(function constantcontinuationp (continuation) boolean))

36 
(defun constantcontinuationp (cont)

37 
(let ((use (continuationuse cont)))

38 
(and (refp use)

39 
(constantp (refleaf use)))))

40 

41 

42 
;;; ContinuationValue  Interface

43 
;;;

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

45 
;;; constant node.

46 
;;;

47 
(proclaim '(function continuationvalue (continuation) t))

48 
(defun continuationvalue (cont)

49 
(assert (constantcontinuationp cont))

50 
(constantvalue (refleaf (continuationuse cont))))

51 

52 

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

54 

55 
;;; CONTINUATIONPROVENTYPE  Interface

56 
;;;

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

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

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

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

61 
;;; using this function directly.

62 
;;;

63 
(defun continuationproventype (cont)

64 
(declare (type continuation cont))

65 
(ecase (continuationkind cont)

66 
((:blockstart :deletedblockstart)

67 
(let ((uses (blockstartuses (continuationblock cont))))

68 
(if uses

69 
(do ((res (nodederivedtype (first uses))

70 
(valuestypeunion (nodederivedtype (first current))

71 
res))

72 
(current (rest uses) (rest current)))

73 
((null current) res))

74 
*emptytype*)))

75 
(:insideblock

76 
(nodederivedtype (continuationuse cont)))))

77 

78 

79 
;;; ContinuationDerivedType  Interface

80 
;;;

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

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

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

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

85 
;;;

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

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

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

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

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

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

92 
;;;

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

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

95 
;;; value there.

96 
;;;

97 
(proclaim '(inline continuationderivedtype))

98 
(defun continuationderivedtype (cont)

99 
(declare (type continuation cont))

100 
(or (continuation%derivedtype cont)

101 
(%continuationderivedtype cont)))

102 
;;;

103 
(defun %continuationderivedtype (cont)

104 
(declare (type continuation cont))

105 
(let ((proven (continuationproventype cont))

106 
(asserted (continuationassertedtype cont)))

107 
(cond ((valuessubtypep proven asserted)

108 
(setf (continuation%typecheck cont) nil)

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

110 
(t

111 
(unless (or (continuation%typecheck cont)

112 
(not (continuationdest cont))

113 
(eq asserted *universaltype*))

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

115 

116 
(setf (continuation%derivedtype cont)

117 
(valuestypeintersection asserted proven))))))

118 

119 

120 
;;; CONTINUATIONTYPECHECK  Interface

121 
;;;

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

123 
;;; return it.

124 
;;;

125 
(proclaim '(inline continuationtypecheck))

126 
(defun continuationtypecheck (cont)

127 
(declare (type continuation cont))

128 
(continuationderivedtype cont)

129 
(continuation%typecheck cont))

130 

131 

132 
;;; ContinuationType  Interface

133 
;;;

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

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

136 
;;;

137 
(proclaim '(function continuationtype (continuation) type))

138 
(defun continuationtype (cont)

139 
(singlevaluetype (continuationderivedtype cont)))

140 

141 

142 
;;;; Interface routines used by optimizers:

143 

144 
;;; ReoptimizeContinuation  Interface

145 
;;;

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

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

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

149 
;;; optimization will fail to terminate.

150 
;;;

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

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

153 
;;; case we do nothing.)

154 
;;;

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

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

157 
;;;

158 
(defun reoptimizecontinuation (cont)

159 
(declare (type continuation cont))

160 
(unless (eq (continuationkind cont) :deleted)

161 
(setf (continuation%derivedtype cont) nil)

162 
(let ((dest (continuationdest cont)))

163 
(when dest

164 
(setf (continuationreoptimize cont) t)

165 
(setf (nodereoptimize dest) t)

166 
(let ((prev (nodeprev dest)))

167 
(when prev

168 
(let* ((block (continuationblock prev))

169 
(component (blockcomponent block)))

170 
(setf (blockreoptimize block) t)

171 
(setf (componentreoptimize component) t))))))

172 
(douses (node cont)

173 
(setf (blocktypecheck (nodeblock node)) t)))

174 
(undefinedvalue))

175 

176 

177 
;;; DeriveNodeType  Interface

178 
;;;

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

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

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

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

183 
;;; may not happen.

184 
;;;

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

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

187 
;;; ReoptimizeContinuation on the NodeCont.

188 
;;;

189 
(defun derivenodetype (node rtype)

190 
(declare (type node node) (type ctype rtype))

191 
(let ((nodetype (nodederivedtype node)))

192 
(unless (eq nodetype rtype)

193 
(let ((int (valuestypeintersection nodetype rtype)))

194 
(when (type/= nodetype int)

195 
(setf (nodederivedtype node) int)

196 
(reoptimizecontinuation (nodecont node))))))

197 
(undefinedvalue))

198 

199 

200 
;;; AssertContinuationType  Interface

201 
;;;

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

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

204 
;;; BLOCKTYPECHECK to guarantee that the new assertion will be checked.

205 
;;;

206 
(defun assertcontinuationtype (cont type)

207 
(declare (type continuation cont) (type ctype type))

208 
(let ((conttype (continuationassertedtype cont)))

209 
(unless (eq conttype type)

210 
(let ((int (valuestypeintersection conttype type)))

211 
(when (type/= conttype int)

212 
(setf (continuationassertedtype cont) int)

213 
(douses (node cont)

214 
(let ((block (nodeblock node)))

215 
(setf (blocktypecheck block) t)

216 
(setf (blocktypeasserted block) t)))

217 
(reoptimizecontinuation cont)))))

218 
(undefinedvalue))

219 

220 

221 
;;; AssertCallType  Interface

222 
;;;

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

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

225 
;;;

226 
(defun assertcalltype (call type)

227 
(declare (type combination call) (type functiontype type))

228 
(derivenodetype call (functiontypereturns type))

229 
(let ((args (combinationargs call)))

230 
(dolist (req (functiontyperequired type))

231 
(when (null args) (returnfrom assertcalltype))

232 
(let ((arg (pop args)))

233 
(assertcontinuationtype arg req)))

234 
(dolist (opt (functiontypeoptional type))

235 
(when (null args) (returnfrom assertcalltype))

236 
(let ((arg (pop args)))

237 
(assertcontinuationtype arg opt)))

238 

239 
(let ((rest (functiontyperest type)))

240 
(when rest

241 
(dolist (arg args)

242 
(assertcontinuationtype arg rest))))

243 

244 
(dolist (key (functiontypekeywords type))

245 
(let ((name (keyinfoname key)))

246 
(do ((arg args (cddr arg)))

247 
((null arg))

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

249 
(assertcontinuationtype

250 
(second arg) (keyinfotype key)))))))

251 
(undefinedvalue))

252 

253 

254 
;;; IR1Optimize  Interface

255 
;;;

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

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

258 
;;; BlockReoptimize set. If ComponentReoptimize is true when we are done,

259 
;;; then another iteration would be beneficial.

260 
;;;

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

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

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

264 
;;; avaliable to IR1 optimization.

265 
;;;

266 
(defun ir1optimize (component)

267 
(declare (type component component))

268 
(setf (componentreoptimize component) nil)

269 
(doblocks (block component)

270 
(cond

271 
((or (blockdeletep block)

272 
(null (blockpred block))

273 
(eq (functionalkind (blocklambda block)) :deleted))

274 
(deleteblock block))

275 
(t

276 
(loop

277 
(let ((succ (blocksucc block)))

278 
(unless (and succ (null (rest succ)))

279 
(return)))

280 

281 
(let ((last (blocklast block)))

282 
(typecase last

283 
(cif

284 
(flushdest (iftest last))

285 
(when (unlinknode last) (return)))

286 
(exit

287 
(when (maybedeleteexit last) (return)))))

288 

289 
(unless (joinsuccessorifpossible block)

290 
(return)))

291 

292 
(when (and (blockreoptimize block)

293 
(blockcomponent block))

294 
(assert (not (blockdeletep block)))

295 
(ir1optimizeblock block))

296 

297 
(when (and (blockflushp block)

298 
(blockcomponent block))

299 
(assert (not (blockdeletep block)))

300 
(flushdeadcode block)))))

301 

302 
(undefinedvalue))

303 

304 

305 
;;; IR1OptimizeBlock  Internal

306 
;;;

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

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

309 
;;; flag set:

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

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

312 
;;; changes.

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

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

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

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

317 
;;; actual unknown exit.

318 
;;;

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

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

321 
;;; necessary. We leave the NODEOPTIMIZE flag set doing into

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

323 
;;;

324 
(defun ir1optimizeblock (block)

325 
(declare (type cblock block))

326 
(setf (blockreoptimize block) nil)

327 
(donodes (node cont block)

328 
(when (nodereoptimize node)

329 
(setf (nodereoptimize node) nil)

330 
(typecase node

331 
(ref)

332 
(combination

333 
(when (continuationreoptimize (basiccombinationfun node))

334 
(propagatefunctionchange node))

335 
(when (dolist (arg (basiccombinationargs node) nil)

336 
(when (and arg (continuationreoptimize arg))

337 
(return t)))

338 
(ir1optimizecombination node)))

339 
(cif

340 
(ir1optimizeif node))

341 
(creturn

342 
(setf (nodereoptimize node) t)

343 
(ir1optimizereturn node))

344 
(mvcombination

345 
(when (and (eq (basiccombinationkind node) :local)

346 
(continuationreoptimize

347 
(first (basiccombinationargs node))))

348 
(ir1optimizemvbind node)))

349 
(exit

350 
(let ((value (exitvalue node)))

351 
(when value

352 
(derivenodetype node (continuationderivedtype value)))))

353 
(cset

354 
(ir1optimizeset node)))))

355 
(undefinedvalue))

356 

357 

358 
;;; JoinSuccessorIfPossible  Internal

359 
;;;

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

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

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

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

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

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

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

367 
;;; transfer is a nonlocal exit.

368 
;;;

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

370 
;;;

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

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

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

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

375 
;;; blocks.

376 
;;;

377 
(defun joinsuccessorifpossible (block)

378 
(declare (type cblock block))

379 
(let ((next (first (blocksucc block))))

380 
(when (blocklambda next)

381 
(let* ((last (blocklast block))

382 
(lastcont (nodecont last))

383 
(nextcont (blockstart next))

384 
(cleanup (blockendcleanup block))

385 
(nextcleanup (blockstartcleanup next))

386 
(lambda (blocklambda block))

387 
(nextlambda (blocklambda next)))

388 
(cond ((or (rest (blockpred next))

389 
(not (eq (continuationuse lastcont) last))

390 
(eq next block)

391 
(not (eq (lambdahome lambda) (lambdahome nextlambda)))

392 
(not (eq (findenclosingcleanup cleanup)

393 
(findenclosingcleanup nextcleanup))))

394 
nil)

395 
((eq lastcont nextcont)

396 
(joinblocks block next)

397 
t)

398 
((and (null (blockstartuses next))

399 
(eq (continuationkind lastcont) :insideblock))

400 
(let ((nextnode (continuationnext nextcont)))

401 
(assert (not (continuationdest nextcont)))

402 
(deletecontinuation nextcont)

403 
(setf (nodeprev nextnode) lastcont)

404 
(setf (continuationnext lastcont) nextnode)

405 
(setf (blockstart next) lastcont)

406 
(joinblocks block next))

407 
t)

408 
(t

409 
nil))))))

410 

411 

412 
;;; JoinBlocks  Internal

413 
;;;

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

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

416 
;;; deleted from the DFO. The EndCleanup for Block1 is set to that for

417 
;;; Block2 so that we don't lose cleanup info. We combine the optimize flags

418 
;;; for the two blocks so that any indicated optimization gets done.

419 
;;;

420 
(defun joinblocks (block1 block2)

421 
(declare (type cblock block1 block2))

422 
(let* ((last (blocklast block2))

423 
(lastcont (nodecont last))

424 
(succ (blocksucc block2))

425 
(start2 (blockstart block2)))

426 
(do ((cont start2 (nodecont (continuationnext cont))))

427 
((eq cont lastcont)

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

429 
(setf (continuationblock lastcont) block1)))

430 
(setf (continuationblock cont) block1))

431 

432 
(unlinkblocks block1 block2)

433 
(dolist (block succ)

434 
(unlinkblocks block2 block)

435 
(linkblocks block1 block))

436 

437 
(setf (blocklast block1) last)

438 
(setf (continuationkind start2) :insideblock))

439 

440 
(setf (blockendcleanup block1) (blockendcleanup block2))

441 

442 
(when (blockreoptimize block2)

443 
(setf (blockreoptimize block1) t))

444 
(when (blockflushp block2)

445 
(setf (blockflushp block1) t))

446 
(when (blocktypecheck block2)

447 
(setf (blocktypecheck block1) t))

448 
(assert (not (blockdeletep block2)))

449 

450 
(setf (blocktypeasserted block1) t)

451 
(setf (blocktestmodified block1) t)

452 

453 
(let ((next (blocknext block2))

454 
(prev (blockprev block2)))

455 
(setf (blocknext prev) next)

456 
(setf (blockprev next) prev))

457 

458 
(undefinedvalue))

459 

460 

461 
;;;; Local call return type propagation:

462 

463 
;;; FindResultType  Internal

464 
;;;

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

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

467 
;;; stuff to update the TAILSET:

468 
;;;  If a use is a local call, then we check that the called function has

469 
;;; the tail set Tails. If we encounter any different tail set, we return

470 
;;; the second value true.

471 
;;;  If a use isn't a local call, then we union its type together with the

472 
;;; types of other such uses. We assign to the RETURNRESULTTYPE the

473 
;;; intersection of this type with the RESULT's asserted type. We can make

474 
;;; this intersection now (potentially before type checking) because this

475 
;;; assertion on the result will eventually be checked (if appropriate.)

476 
;;;

477 
(defun findresulttype (node tails)

478 
(declare (type creturn node))

479 
(let ((result (returnresult node))

480 
(retry nil))

481 
(collect ((useunion *emptytype* valuestypeunion))

482 
(douses (use result)

483 
(if (and (basiccombinationp use)

484 
(eq (basiccombinationkind use) :local))

485 
(when (mergetailsets use tails)

486 
(setq retry t))

487 
(useunion (nodederivedtype use))))

488 
(let ((int (valuestypeintersection

489 
(continuationassertedtype result)

490 
(useunion))))

491 
(setf (returnresulttype node) int)))

492 
retry))

493 

494 

495 
;;; MergeTailSets  Internal

496 
;;;

497 
;;; This function handles merging the tail sets if Call is a call to a

498 
;;; function with a different TAILSET than RetSet. We return true if we do

499 
;;; anything.

500 
;;;

501 
;;; It is assumed that Call sends its value to a RETURN node. We

502 
;;; destructively modify the set for the returning function to represent both,

503 
;;; and then change all the functions in callee's set to reference the first.

504 
;;;

505 
;;; If the called function has no tail set, then do nothing; if it doesn't

506 
;;; return, then it can't affect the callers value.

507 
;;;

508 
(defun mergetailsets (call retset)

509 
(declare (type basiccombination call) (type tailset retset))

510 
(let ((funset (lambdatailset (combinationlambda call))))

511 
(when (and funset (not (eq retset funset)))

512 
(let ((funs (tailsetfunctions funset)))

513 
(dolist (fun funs)

514 
(setf (lambdatailset fun) retset))

515 
(setf (tailsetfunctions retset)

516 
(nconc (tailsetfunctions retset) funs)))

517 
t)))

518 

519 

520 
;;; IR1OptimizeReturn  Internal

521 
;;;

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

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

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

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

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

527 
;;;

528 
;;; During this iteration, we may discover new functions that should be

529 
;;; added to the tail set. If this happens, we restart the iteration over the

530 
;;; TAILSETFUNCTIONS. Note that this really doesn't duplicate much work, as

531 
;;; we clear the NODEREOPTIMIZE flags in the return nodes as we go, thus we

532 
;;; don't call FINDRESULTTYPE on any given return more than once.

533 
;;;

534 
;;; Restarting the iteration doesn't disturb the computation of the result

535 
;;; type RES, since we will just be adding more types to the union. (or when

536 
;;; we iterate over a return multiple times, unioning in the same type more

537 
;;; than once.)

538 
;;;

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

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

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

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

543 
;;; calls.

544 
;;;

545 
(defun ir1optimizereturn (node)

546 
(declare (type creturn node))

547 
(let ((tails (lambdatailset (returnlambda node))))

548 
(collect ((res *emptytype* valuestypeunion))

549 
(loop

550 
(block RETRY

551 
(let ((funs (tailsetfunctions tails)))

552 
(dolist (fun funs)

553 
(let ((return (lambdareturn fun)))

554 
(when (nodereoptimize return)

555 
(setf (nodereoptimize node) nil)

556 
(when (findresulttype return tails) (returnfrom RETRY)))

557 
(res (returnresulttype return)))))

558 
(return)))

559 

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

561 
(setf (tailsettype tails) (res))

562 
(dolist (fun (tailsetfunctions tails))

563 
(dolist (ref (leafrefs fun))

564 
(reoptimizecontinuation (nodecont ref)))))))

565 

566 
(undefinedvalue))

567 

568 

569 
;;; IR1OptimizeIf  Internal

570 
;;;

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

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

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

574 
;;;

575 
(defun ir1optimizeif (node)

576 
(declare (type cif node))

577 
(let ((test (iftest node))

578 
(block (nodeblock node)))

579 

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

581 
(eq (continuationnext test) node)

582 
(rest (blockstartuses block)))

583 
(douses (use test)

584 
(when (immediatelyusedp test use)

585 
(convertifif use node)

586 
(when (continuationuse test) (return)))))

587 

588 
(let* ((type (continuationtype test))

589 
(victim

590 
(cond ((constantcontinuationp test)

591 
(if (continuationvalue test)

592 
(ifalternative node)

593 
(ifconsequent node)))

594 
((not (typesintersect type *nulltype*))

595 
(ifalternative node))

596 
((type= type *nulltype*)

597 
(ifconsequent node)))))

598 
(when victim

599 
(flushdest test)

600 
(when (rest (blocksucc block))

601 
(unlinkblocks block victim))

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

603 
(unlinknode node))))

604 
(undefinedvalue))

605 

606 

607 
;;; ConvertIfIf  Internal

608 
;;;

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

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

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

612 
;;;

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

614 
;;; sourcetosource transformation:

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

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

617 
;;;

618 
(defun convertifif (use node)

619 
(declare (type node use) (type cif node))

620 
(withir1environment node

621 
(let* ((block (nodeblock node))

622 
(test (iftest node))

623 
(cblock (ifconsequent node))

624 
(ablock (ifalternative node))

625 
(useblock (nodeblock use))

626 
(dummycont (makecontinuation))

627 
(newcont (makecontinuation))

628 
(newnode (makeif :test newcont :source (nodesource node)

629 
:consequent cblock :alternative ablock))

630 
(newblock (continuationstartsblock newcont)))

631 
(prevlink newnode newcont)

632 
(setf (continuationdest newcont) newnode)

633 
(addcontinuationuse newnode dummycont)

634 
(setf (blocklast newblock) newnode)

635 

636 
(unlinkblocks useblock block)

637 
(deletecontinuationuse use)

638 
(addcontinuationuse use newcont)

639 
(linkblocks useblock newblock)

640 

641 
(linkblocks newblock cblock)

642 
(linkblocks newblock ablock)

643 

644 
(reoptimizecontinuation test)

645 
(reoptimizecontinuation newcont)

646 
(setf (componentreanalyze *currentcomponent*) t)))

647 
(undefinedvalue))

648 

649 

650 
;;;; Exit IR1 optimization:

651 

652 
;;; MaybeDeleteExit  Interface

653 
;;;

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

655 
;;; deletes the block as a consequence:

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

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

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

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

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

661 
;;; node.

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

663 
;;;

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

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

666 
;;;

667 
(defun maybedeleteexit (node)

668 
(declare (type exit node))

669 
(let ((value (exitvalue node))

670 
(entry (exitentry node))

671 
(cont (nodecont node)))

672 
(when (and entry

673 
(eq (lambdahome (blocklambda (nodeblock node)))

674 
(lambdahome (blocklambda (nodeblock entry)))))

675 
(prog1

676 
(unlinknode node)

677 
(when value

678 
(substitutecontinuationuses cont value))))))

679 

680 

681 
;;;; Combination IR1 optimization:

682 

683 
;;; Ir1OptimizeCombination  Internal

684 
;;;

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

686 
;;;

687 
(proclaim '(function ir1optimizecombination (combination) void))

688 
(defun ir1optimizecombination (node)

689 
(let ((args (basiccombinationargs node))

690 
(kind (basiccombinationkind node)))

691 
(case kind

692 
(:local

693 
(let ((fun (combinationlambda node)))

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

695 
(propagateletargs node fun)

696 
(propagatelocalcallargs node fun))))

697 
(:full

698 
(dolist (arg args)

699 
(when arg

700 
(setf (continuationreoptimize arg) nil))))

701 
(t

702 
(dolist (arg args)

703 
(when arg

704 
(setf (continuationreoptimize arg) nil)))

705 

706 
(let ((attr (functioninfoattributes kind)))

707 
(when (and (ir1attributep attr foldable)

708 
(not (ir1attributep attr call))

709 
(every #'constantcontinuationp args)

710 
(continuationdest (nodecont node)))

711 
(constantfoldcall node)

712 
(returnfrom ir1optimizecombination)))

713 

714 
(let ((fun (functioninfoderivetype kind)))

715 
(when fun

716 
(let ((res (funcall fun node)))

717 
(when res

718 
(derivenodetype node res)))))

719 

720 
(let ((fun (functioninfooptimizer kind)))

721 
(unless (and fun (funcall fun node))

722 
(dolist (x (functioninfotransforms kind))

723 
(unless (ir1transform node (car x) (cdr x))

724 
(return))))))))

725 

726 
(undefinedvalue))

727 

728 

729 
;;; RecognizeKnownCall  Interface

730 
;;;

731 
;;; If Call is a call to a known function, mark it as such by setting the

732 
;;; Kind. In addition to a direct check for the function name in the table, we

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

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

735 
;;; %SlotAccessor, as appropriate.

736 
;;;

737 
(defun recognizeknowncall (call)

738 
(declare (type combination call))

739 
(let* ((fun (basiccombinationfun call))

740 
(name (continuationfunctionname fun)))

741 
(when name

742 
(let ((info (info function info name)))

743 
(cond (info

744 
(setf (basiccombinationkind call) info))

745 
((slotaccessorp (refleaf (continuationuse fun)))

746 
(setf (basiccombinationkind call)

747 
(info function info

748 
(if (consp name)

749 
'%slotsetter

750 
'%slotaccessor))))))))

751 
(undefinedvalue))

752 

753 

754 
;;; PropagateFunctionChange  Internal

755 
;;;

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

757 
;;; If the call is to a functional, then we attempt to convert it to a local

758 
;;; call, otherwise we check the call for legality with respect to the new

759 
;;; type; if it is illegal, we mark the Ref as :Notline and punt.

760 
;;;

761 
;;; If we do have a good type for the call, we propagate type information from

762 
;;; the type to the arg and result continuations. If we discover that the call

763 
;;; is to a known global function, then we mark the combination as known.

764 
;;;

765 
(defun propagatefunctionchange (call)

766 
(declare (type combination call))

767 
(let* ((fun (combinationfun call))

768 
(use (continuationuse fun))

769 
(type (continuationderivedtype fun))

770 
(*compilererrorcontext* call))

771 
(setf (continuationreoptimize fun) nil)

772 
(cond ((or (not (refp use))

773 
(eq (refinlinep use) :notinline)))

774 
((functionalp (refleaf use))

775 
(let ((leaf (refleaf use)))

776 
(cond ((eq (combinationkind call) :local)

777 
(let ((tailset (lambdatailset leaf)))

778 
(when tailset

779 
(derivenodetype

780 
call (tailsettype tailset)))))

781 
((not (eq (refinlinep use) :notinline))

782 
(convertcallifpossible use call)

783 
(maybeletconvert leaf)))))

784 
((not (functiontypep type)))

785 
((validfunctionuse call type

786 
:argumenttest #'alwayssubtypep

787 
:resulttest #'alwayssubtypep

788 
:errorfunction #'compilerwarning

789 
:warningfunction #'compilernote)

790 
(assertcalltype call type)

791 
(recognizeknowncall call))

792 
(t

793 
(setf (refinlinep use) :notinline))))

794 

795 
(undefinedvalue))

796 

797 

798 
;;;; Known function optimization:

799 

800 
;;; IR1Transform  Internal

801 
;;;

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

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

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

805 
;;; *failedoptimizations* for IR1 finalize to pick up. We return true if

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

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

808 
;;; aborted.

809 
;;;

810 
(defun ir1transform (node type fun)

811 
(declare (type combination node) (type ctype type) (type function fun))

812 
(let ((constrained (functiontypep type))

813 
(flame (policy node (> speed brevity)))

814 
(*compilererrorcontext* node))

815 
(cond ((or (not constrained)

816 
(validfunctionuse node type))

817 
(multiplevaluebind

818 
(severity args)

819 
(catch 'giveup

820 
(transformcall node (funcall fun node))

821 
(remhash node *failedoptimizations*)

822 
(values :none nil))

823 
(ecase severity

824 
(:none nil)

825 
(:aborted

826 
(setf (combinationkind node) :full)

827 
(setf (refinlinep (continuationuse (combinationfun node)))

828 
:notinline)

829 
(when args

830 
(apply #'compilerwarning args))

831 
nil)

832 
(:failure

833 
(when (and flame args)

834 
(setf (gethash node *failedoptimizations*) args))

835 
t))))

836 
((and flame

837 
(validfunctionuse node type

838 
:argumenttest #'typesintersect

839 
:resulttest #'valuestypesintersect))

840 
(setf (gethash node *failedoptimizations*) type)

841 
t))))

842 

843 

844 
;;; GIVEUP, ABORTTRANSFORM  Interface

845 
;;;

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

847 
;;;

848 
(proclaim '(function giveup (&rest t) nil))

849 
(defun giveup (&rest args)

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

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

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

853 
format arguments for an efficiency note."

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

855 
;;;

856 
(defun aborttransform (&rest args)

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

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

859 
attempted."

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

861 

862 

863 
;;; TransformCall  Internal

864 
;;;

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

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

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

868 
;;; flow. We set the Reanalyze flag in the component to cause the DFO to be

869 
;;; recomputed at soonest convenience.

870 
;;;

871 
(defun transformcall (node res)

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

873 
(withir1environment node

874 
(let ((newfun (ir1convertlambda res (nodesource node)))

875 
(ref (continuationuse (combinationfun node))))

876 
(changerefleaf ref newfun)

877 
(setf (combinationkind node) :full)

878 
(localcallanalyze *currentcomponent*)))

879 
(undefinedvalue))

880 

881 

882 
;;; ConstantFoldCall  Internal

883 
;;;

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

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

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

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

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

889 
;;; leave the call alone, making the call a full call and marking it as

890 
;;; :notinline to make sure that it stays that way.

891 
;;;

892 
;;; For now, if the result is other than one value, we don't fold it.

893 
;;;

894 
(defun constantfoldcall (call)

895 
(declare (type combination call))

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

897 
(ref (continuationuse (combinationfun call)))

898 
(fun (leafname (refleaf ref))))

899 

900 
(multiplevaluebind (values win)

901 
(carefulcall fun args call "constant folding")

902 
(cond

903 
((not win)

904 
(setf (refinlinep ref) :notinline)

905 
(setf (combinationkind call) :full))

906 
((= (length values) 1)

907 
(withir1environment call

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

909 
(node (makeref (leaftype leaf)

910 
(nodesource call)

911 
leaf

912 
nil))

913 
(dummy (makecontinuation))

914 
(cont (nodecont call))

915 
(block (nodeblock call))

916 
(next (continuationnext cont)))

917 
(push node (leafrefs leaf))

918 
(setf (leafeverused leaf) t)

919 

920 
(deletecontinuationuse call)

921 
(addcontinuationuse call dummy)

922 
(prevlink node dummy)

923 
(addcontinuationuse node cont)

924 
(setf (continuationnext cont) next)

925 
(when (eq call (blocklast block))

926 
(setf (blocklast block) node))

927 
(reoptimizecontinuation cont)))))))

928 

929 
(undefinedvalue))

930 

931 

932 
;;;; Local call optimization:

933 

934 
;;; PropagateToRefs  Internal

935 
;;;

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

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

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

939 
;;;

940 
(defun propagatetorefs (leaf type)

941 
(declare (type leaf leaf) (type ctype type))

942 
(let ((vartype (leaftype leaf)))

943 
(unless (functiontypep vartype)

944 
(let ((int (typeintersection vartype type)))

945 
(when (type/= int vartype)

946 
(setf (leaftype leaf) int)

947 
(dolist (ref (leafrefs leaf))

948 
(derivenodetype ref int))))

949 
(undefinedvalue))))

950 

951 

952 
;;; PROPAGATEFROMSETS  Internal

953 
;;;

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

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

956 
;;; a PROPAGATETOREFS with this type.

957 
;;;

958 
(defun propagatefromsets (var type)

959 
(collect ((res type typeunion))

960 
(dolist (set (basicvarsets var))

961 
(res (continuationtype (setvalue set)))

962 
(setf (nodereoptimize set) nil))

963 
(propagatetorefs var (res)))

964 
(undefinedvalue))

965 

966 

967 
;;; IR1OPTIMIZESET  Internal

968 
;;;

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

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

971 
;;;

972 
(defun ir1optimizeset (node)

973 
(declare (type cset node))

974 
(let ((var (setvar node)))

975 
(when (and (lambdavarp var) (leafrefs var))

976 
(let ((home (lambdavarhome var)))

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

978 
(let ((iv (letvarinitialvalue var)))

979 
(setf (continuationreoptimize iv) nil)

980 
(propagatefromsets var (continuationtype iv)))))))

981 

982 
(derivenodetype node (continuationtype (setvalue node)))

983 
(undefinedvalue))

984 

985 

986 
;;; CONSTANTREFERENCEP  Internal

987 
;;;

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

989 
;;; legal to substitute.)

990 
;;;

991 
(defun constantreferencep (ref)

992 
(declare (type ref ref))

993 
(let ((leaf (refleaf ref)))

994 
(typecase leaf

995 
(constant t)

996 
(functional t)

997 
(lambdavar

998 
(null (lambdavarsets leaf)))

999 
(globalvar

1000 
(case (globalvarkind leaf)

1001 
(:globalfunction

1002 
(not (eq (refinlinep ref) :notinline)))

1003 
(:constant t))))))

1004 

1005 

1006 
;;; SUBSTITUTESINGLEUSECONTINUATION  Internal

1007 
;;;

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

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

1010 
;;; inhibited when:

1011 
;;;  CONT has other uses, or

1012 
;;;  CONT receives multiple values, or

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

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

1015 
;;;

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

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

1018 
;;; the variable.

1019 
;;;

1020 
(defun substitutesingleusecontinuation (arg var)

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

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

1023 
(cont (nodecont ref))

1024 
(dest (continuationdest cont)))

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

1026 
dest

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

1028 
(eq (lambdahome (blocklambda (nodeblock ref)))

1029 
(lambdahome (lambdavarhome var)))

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

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

1032 
(assertcontinuationtype arg (continuationassertedtype cont))

1033 
(changerefleaf ref (findconstant nil))

1034 
(substitutecontinuation arg cont)

1035 
(reoptimizecontinuation arg)

1036 
t)))

1037 

1038 

1039 
;;; PropagateLetArgs  Internal

1040 
;;;

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

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

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

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

1045 
;;; the Var's refs.

1046 
;;;

1047 
;;; Substitution is inhibited when the Ref's derived type isn't a subtype of

1048 
;;; the argument's asserted type. This prevents type checking from being

1049 
;;; defeated, and also ensures that the best representation for the variable

1050 
;;; can be used.

1051 
;;;

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

1053 
;;; flags.

1054 
;;;

1055 
(defun propagateletargs (call fun)

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

1057 
(mapc #'(lambda (arg var)

1058 
(when (and arg

1059 
(continuationreoptimize arg))

1060 
(setf (continuationreoptimize arg) nil)

1061 
(cond

1062 
((lambdavarsets var)

1063 
(propagatefromsets var (continuationtype arg)))

1064 
((let ((use (continuationuse arg)))

1065 
(when (refp use)

1066 
(let ((leaf (refleaf use)))

1067 
(when (and (constantreferencep use)

1068 
(valuessubtypep

1069 
(nodederivedtype use)

1070 
(continuationassertedtype arg)))

1071 
(substituteleaf leaf var)

1072 
(propagatetorefs var (continuationtype arg))

1073 
t)))))

1074 
((and (null (rest (leafrefs var)))

1075 
(substitutesingleusecontinuation arg var)))

1076 
(t

1077 
(propagatetorefs var (continuationtype arg))))))

1078 
(basiccombinationargs call)

1079 
(lambdavars fun))

1080 
(undefinedvalue))

1081 

1082 

1083 
;;; PropagateLocalCallArgs  Internal

1084 
;;;

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

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

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

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

1089 
;;;

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

1091 
;;; discover anything.

1092 
;;;

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

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

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

1096 
;;;

1097 
(defun propagatelocalcallargs (call fun)

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

1099 

1100 
(unless (functionalentryfunction fun)

1101 
(let* ((vars (lambdavars fun))

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

1103 
(when (and arg

1104 
(continuationreoptimize arg)

1105 
(null (basicvarsets var)))

1106 
(continuationtype arg)))

1107 
(basiccombinationargs call)

1108 
vars))

1109 
(thisref (continuationuse (basiccombinationfun call))))

1110 

1111 
(dolist (arg (basiccombinationargs call))

1112 
(when arg

1113 
(setf (continuationreoptimize arg) nil)))

1114 

1115 
(dolist (ref (leafrefs fun))

1116 
(unless (eq ref thisref)

1117 
(setq union

1118 
(mapcar #'(lambda (thisarg old)

1119 
(when old

1120 
(setf (continuationreoptimize thisarg) nil)

1121 
(typeunion (continuationtype thisarg) old)))

1122 
(basiccombinationargs

1123 
(continuationdest (nodecont ref)))

1124 
union))))

1125 

1126 
(mapc #'(lambda (var type)

1127 
(when type

1128 
(propagatetorefs var type)))

1129 
vars union)))

1130 

1131 
(undefinedvalue))

1132 

1133 

1134 
;;; IR1OPTIMIZEMVBIND  Internal

1135 
;;;

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

1137 
;;;

1138 
(defun ir1optimizemvbind (node)

1139 
(declare (type mvcombination node))

1140 
(let ((arg (first (basiccombinationargs node)))

1141 
(vars (lambdavars (combinationlambda node))))

1142 
(multiplevaluebind (types nvals)

1143 
(valuestypes (continuationderivedtype arg))

1144 
(unless (eq nvals :unknown)

1145 
(mapc #'(lambda (var type)

1146 
(if (basicvarsets var)

1147 
(propagatefromsets var type)

1148 
(propagatetorefs var type)))

1149 
vars

1150 
(append types

1151 
(makelist (max ( (length vars) nvals) 0)

1152 
:initialelement *nulltype*)))))

1153 

1154 
(setf (continuationreoptimize arg) nil))

1155 
(undefinedvalue))

1156 

1157 

1158 
;;; FlushDeadCode  Internal

1159 
;;;

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

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

1162 
;;; variable has no references.

1163 
;;;

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

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

1166 
;;; if they have any sideeffects.]

1167 
;;;

1168 
(defun flushdeadcode (block)

1169 
(declare (type cblock block))

1170 
(donodesbackwards (node cont block)

1171 
(unless (continuationdest cont)

1172 
(typecase node

1173 
(ref

1174 
(deleteref node)

1175 
(unlinknode node))

1176 
(combination

1177 
(let ((info (combinationkind node)))

1178 
(when (functioninfop info)

1179 
(let ((attr (functioninfoattributes info)))

1180 
(when (and (ir1attributep attr flushable)

1181 
(not (ir1attributep attr call)))

1182 
(flushdest (combinationfun node))

1183 
(dolist (arg (combinationargs node))

1184 
(flushdest arg))

1185 
(unlinknode node))))))

1186 
(exit

1187 
(let ((value (exitvalue node)))

1188 
(when value

1189 
(flushdest value)

1190 
(setf (exitvalue node) nil))))

1191 
(cset

1192 
(let ((var (setvar node)))

1193 
(when (and (lambdavarp var)

1194 
(null (leafrefs var)))

1195 
(flushdest (setvalue node))

1196 
(setf (basicvarsets var)

1197 
(delete node (basicvarsets var)))

1198 
(unlinknode node)))))))

1199 

1200 
(setf (blockflushp block) nil)

1201 
(undefinedvalue))

1202 
