~ubuntu-branches/ubuntu/precise/ghc/precise

WARN(not (from_ty `coreEqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ pprEqPred (coercionKind co))

218

(Cast expr co)

219

\end{code}

220

221

\begin{code}

222

-- | Wraps the given expression in the cost centre unless

223

-- in a way that maximises their utility to the user

224

mkSCC :: CostCentre -> Expr b -> Expr b

225

-- Note: Nested SCC's *are* preserved for the benefit of

226

-- cost centre stack profiling

227

mkSCC _ (Lit lit) = Lit lit

228

mkSCC cc (Lam x e) = Lam x (mkSCC cc e) -- Move _scc_ inside lambda

229

mkSCC cc (Note (SCC cc') e) = Note (SCC cc) (Note (SCC cc') e)

230

mkSCC cc (Note n e) = Note n (mkSCC cc e) -- Move _scc_ inside notes

231

mkSCC cc (Cast e co) = Cast (mkSCC cc e) co -- Move _scc_ inside cast

232

mkSCC cc expr = Note (SCC cc) expr

233

\end{code}

234

235

236

%************************************************************************

237

%* *

238

\subsection{Other expression construction}

239

%* *

240

%************************************************************************

241

242

\begin{code}

243

bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr

244

-- ^ @bindNonRec x r b@ produces either:

245

246

-- > let x = r in b

247

248

-- or:

249

250

-- > case r of x { _DEFAULT_ -> b }

251

252

-- depending on whether we have to use a @case@ or @let@

253

-- binding for the expression (see 'needsCaseBinding').

254

-- It's used by the desugarer to avoid building bindings

255

-- that give Core Lint a heart attack, although actually

256

-- the simplifier deals with them perfectly well. See

257

-- also 'MkCore.mkCoreLet'

258

bindNonRec bndr rhs body

259

| needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT, [], body)]

260

| otherwise = Let (NonRec bndr rhs) body

261

262

-- | Tests whether we have to use a @case@ rather than @let@ binding for this expression

263

-- as per the invariants of 'CoreExpr': see "CoreSyn#let_app_invariant"

264

needsCaseBinding :: Type -> CoreExpr -> Bool

265

needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)

266

-- Make a case expression instead of a let

267

-- These can arise either from the desugarer,

268

-- or from beta reductions: (\x.e) (x +# y)

269

\end{code}

270

271

\begin{code}

272

mkAltExpr :: AltCon -- ^ Case alternative constructor

273

-> [CoreBndr] -- ^ Things bound by the pattern match

274

-> [Type] -- ^ The type arguments to the case alternative

275

-> CoreExpr

276

-- ^ This guy constructs the value that the scrutinee must have

277

-- given that you are in one particular branch of a case

278

mkAltExpr (DataAlt con) args inst_tys

279

= mkConApp con (map Type inst_tys ++ varsToCoreExprs args)

280

mkAltExpr (LitAlt lit) [] []

281

= Lit lit

282

mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt"

283

mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT"

284

\end{code}

285

286

287

%************************************************************************

288

%* *

289

\subsection{Taking expressions apart}

290

%* *

291

%************************************************************************

292

293

The default alternative must be first, if it exists at all.

294

This makes it easy to find, though it makes matching marginally harder.

295

296

\begin{code}

297

-- | Extract the default case alternative

298

findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)

299

findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)

300

findDefault alts = (alts, Nothing)

301

302

isDefaultAlt :: CoreAlt -> Bool

303

isDefaultAlt (DEFAULT, _, _) = True

304

isDefaultAlt _ = False

305

306

307

-- | Find the case alternative corresponding to a particular

308

-- constructor: panics if no such constructor exists

309

findAlt :: AltCon -> [CoreAlt] -> Maybe CoreAlt

310

-- A "Nothing" result *is* legitmiate

311

-- See Note [Unreachable code]

312

findAlt con alts

313

= case alts of

314

(deflt@(DEFAULT,_,_):alts) -> go alts (Just deflt)

315

_ -> go alts Nothing

316

where

317

go [] deflt = deflt

318

go (alt@(con1,_,_) : alts) deflt

319

= case con `cmpAltCon` con1 of

320

LT -> deflt -- Missed it already; the alts are in increasing order

321

EQ -> Just alt

322

GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt

323

324

---------------------------------

325

mergeAlts :: [CoreAlt] -> [CoreAlt] -> [CoreAlt]

326

-- ^ Merge alternatives preserving order; alternatives in

327

-- the first argument shadow ones in the second

328

mergeAlts [] as2 = as2

329

mergeAlts as1 [] = as1

330

mergeAlts (a1:as1) (a2:as2)

331

= case a1 `cmpAlt` a2 of

332

LT -> a1 : mergeAlts as1 (a2:as2)

333

EQ -> a1 : mergeAlts as1 as2 -- Discard a2

334

GT -> a2 : mergeAlts (a1:as1) as2

335

336

337

---------------------------------

338

trimConArgs :: AltCon -> [CoreArg] -> [CoreArg]

339

-- ^ Given:

340

341

-- > case (C a b x y) of

342

-- > C b x y -> ...

343

344

-- We want to drop the leading type argument of the scrutinee

345

-- leaving the arguments to match agains the pattern

346

347

trimConArgs DEFAULT args = ASSERT( null args ) []

348

trimConArgs (LitAlt _) args = ASSERT( null args ) []

349

trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args

350

\end{code}

351

352

Note [Unreachable code]

353

~~~~~~~~~~~~~~~~~~~~~~~

354

It is possible (although unusual) for GHC to find a case expression

355

that cannot match. For example:

356

357

data Col = Red | Green | Blue

358

x = Red

359

f v = case x of

360

Red -> ...

361

_ -> ...(case x of { Green -> e1; Blue -> e2 })...

362

363

Suppose that for some silly reason, x isn't substituted in the case

364

expression. (Perhaps there's a NOINLINE on it, or profiling SCC stuff

365

gets in the way; cf Trac #3118.) Then the full-lazines pass might produce

366

this

367

368

x = Red

369

lvl = case x of { Green -> e1; Blue -> e2 })

370

f v = case x of

371

Red -> ...

372

_ -> ...lvl...

373

374

Now if x gets inlined, we won't be able to find a matching alternative

375

for 'Red'. That's because 'lvl' is unreachable. So rather than crashing

376

we generate (error "Inaccessible alternative").

377

378

Similar things can happen (augmented by GADTs) when the Simplifier

379

filters down the matching alternatives in Simplify.rebuildCase.

380

381

382

%************************************************************************

383

%* *

384

exprIsTrivial

385

%* *

386

%************************************************************************

387

388

Note [exprIsTrivial]

389

~~~~~~~~~~~~~~~~~~~~

390

@exprIsTrivial@ is true of expressions we are unconditionally happy to

391

duplicate; simple variables and constants, and type

392

applications. Note that primop Ids aren't considered

393

trivial unless

394

395

Note [Variable are trivial]

396

~~~~~~~~~~~~~~~~~~~~~~~~~~~

397

There used to be a gruesome test for (hasNoBinding v) in the

398

Var case:

399

exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0

400

The idea here is that a constructor worker, like \$wJust, is

401

really short for (\x -> \$wJust x), becuase \$wJust has no binding.

402

So it should be treated like a lambda. Ditto unsaturated primops.

403

But now constructor workers are not "have-no-binding" Ids. And

404

completely un-applied primops and foreign-call Ids are sufficiently

405

rare that I plan to allow them to be duplicated and put up with

406

saturating them.

407

408

Note [SCCs are trivial]

409

~~~~~~~~~~~~~~~~~~~~~~~

410

We used not to treat (_scc_ "foo" x) as trivial, because it really

411

generates code, (and a heap object when it's a function arg) to

412

capture the cost centre. However, the profiling system discounts the

413

allocation costs for such "boxing thunks" whereas the extra costs of

414

*not* inlining otherwise-trivial bindings can be high, and are hard to

415

discount.

416

417

\begin{code}

418

exprIsTrivial :: CoreExpr -> Bool

419

exprIsTrivial (Var _) = True -- See Note [Variables are trivial]

420

exprIsTrivial (Type _) = True

421

exprIsTrivial (Lit lit) = litIsTrivial lit

422

exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e

423

exprIsTrivial (Note _ e) = exprIsTrivial e -- See Note [SCCs are trivial]

424

exprIsTrivial (Cast e _) = exprIsTrivial e

425

exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body

426

exprIsTrivial _ = False

427

\end{code}

428

429

430

%************************************************************************

431

%* *

432

exprIsDupable

433

%* *

434

%************************************************************************

435

436

Note [exprIsDupable]

437

~~~~~~~~~~~~~~~~~~~~

438

@exprIsDupable@ is true of expressions that can be duplicated at a modest

439

cost in code size. This will only happen in different case

440

branches, so there's no issue about duplicating work.

441

442

That is, exprIsDupable returns True of (f x) even if

443

f is very very expensive to call.

444

445

Its only purpose is to avoid fruitless let-binding

446

and then inlining of case join points

447

448

449

\begin{code}

450

exprIsDupable :: CoreExpr -> Bool

451

exprIsDupable (Type _) = True

452

exprIsDupable (Var _) = True

453

exprIsDupable (Lit lit) = litIsDupable lit

454

exprIsDupable (Note _ e) = exprIsDupable e

455

exprIsDupable (Cast e _) = exprIsDupable e

456

exprIsDupable expr

457

= go expr 0

458

where

459

go (Var _) _ = True

460

go (App f a) n_args = n_args < dupAppSize

461

&& exprIsDupable a

462

&& go f (n_args+1)

463

go _ _ = False

464

465

dupAppSize :: Int

466

dupAppSize = 4 -- Size of application we are prepared to duplicate

467

\end{code}

468

469

%************************************************************************

470

%* *

471

exprIsCheap, exprIsExpandable

472

%* *

473

%************************************************************************

474

475

Note [exprIsCheap] See also Note [Interaction of exprIsCheap and lone variables]

476

~~~~~~~~~~~~~~~~~~ in CoreUnfold.lhs

477

@exprIsCheap@ looks at a Core expression and returns \tr{True} if

478

it is obviously in weak head normal form, or is cheap to get to WHNF.

479

[Note that that's not the same as exprIsDupable; an expression might be

480

big, and hence not dupable, but still cheap.]

481

482

By ``cheap'' we mean a computation we're willing to:

483

push inside a lambda, or

484

inline at more than one place

485

That might mean it gets evaluated more than once, instead of being

486

shared. The main examples of things which aren't WHNF but are

487

``cheap'' are:

488

489

* case e of

490

pi -> ei

491

(where e, and all the ei are cheap)

492

493

* let x = e in b

494

(where e and b are cheap)

495

496

* op x1 ... xn

497

(where op is a cheap primitive operator)

498

499

* error "foo"

500

(because we are happy to substitute it inside a lambda)

501

502

Notice that a variable is considered 'cheap': we can push it inside a lambda,

503

because sharing will make sure it is only evaluated once.

504

505

Note [exprIsCheap and exprIsHNF]

506

~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

507

Note that exprIsHNF does not imply exprIsCheap. Eg

508

let x = fac 20 in Just x

509

This responds True to exprIsHNF (you can discard a seq), but

510

False to exprIsCheap.

511

512

\begin{code}

513

exprIsCheap :: CoreExpr -> Bool

514

exprIsCheap = exprIsCheap' isCheapApp

515

516

exprIsExpandable :: CoreExpr -> Bool

517

exprIsExpandable = exprIsCheap' isExpandableApp -- See Note [CONLIKE pragma] in BasicTypes

518

519

520

exprIsCheap' :: (Id -> Int -> Bool) -> CoreExpr -> Bool

521

exprIsCheap' _ (Lit _) = True

522

exprIsCheap' _ (Type _) = True

523

exprIsCheap' _ (Var _) = True

524

exprIsCheap' good_app (Note _ e) = exprIsCheap' good_app e

525

exprIsCheap' good_app (Cast e _) = exprIsCheap' good_app e

526

exprIsCheap' good_app (Lam x e) = isRuntimeVar x

527

|| exprIsCheap' good_app e

528

529

exprIsCheap' good_app (Case e _ _ alts) = exprIsCheap' good_app e &&

530

and [exprIsCheap' good_app rhs | (_,_,rhs) <- alts]

531

-- Experimentally, treat (case x of ...) as cheap

532

-- (and case __coerce x etc.)

533

-- This improves arities of overloaded functions where

534

-- there is only dictionary selection (no construction) involved

535

536

exprIsCheap' good_app (Let (NonRec x _) e)

537

| isUnLiftedType (idType x) = exprIsCheap' good_app e

538

| otherwise = False

539

-- Strict lets always have cheap right hand sides,

540

-- and do no allocation, so just look at the body

541

-- Non-strict lets do allocation so we don't treat them as cheap

542

-- See also

543

544

exprIsCheap' good_app other_expr -- Applications and variables

545

= go other_expr []

546

where

547

-- Accumulate value arguments, then decide

548

go (App f a) val_args | isRuntimeArg a = go f (a:val_args)

549

| otherwise = go f val_args

550

551

go (Var _) [] = True -- Just a type application of a variable

552

-- (f t1 t2 t3) counts as WHNF

553

go (Var f) args

554

= case idDetails f of

555

RecSelId {} -> go_sel args

556

ClassOpId {} -> go_sel args

557

PrimOpId op -> go_primop op args

558

_ | good_app f (length args) -> go_pap args

559

| isBottomingId f -> True

560

| otherwise -> False

561

-- Application of a function which

562

-- always gives bottom; we treat this as cheap

563

-- because it certainly doesn't need to be shared!

564

565

go _ _ = False

566

567

--------------

568

go_pap args = all exprIsTrivial args

569

-- For constructor applications and primops, check that all

570

-- the args are trivial. We don't want to treat as cheap, say,

571

-- (1:2:3:4:5:[])

572

-- We'll put up with one constructor application, but not dozens

573

574

--------------

575

go_primop op args = primOpIsCheap op && all (exprIsCheap' good_app) args

576

-- In principle we should worry about primops

577

-- that return a type variable, since the result

578

-- might be applied to something, but I'm not going

579

-- to bother to check the number of args

580

581

--------------

582

go_sel [arg] = exprIsCheap' good_app arg -- I'm experimenting with making record selection

583

go_sel _ = False -- look cheap, so we will substitute it inside a

584

-- lambda. Particularly for dictionary field selection.

585

-- BUT: Take care with (sel d x)! The (sel d) might be cheap, but

586

-- there's no guarantee that (sel d x) will be too. Hence (n_val_args == 1)

587

588

isCheapApp :: Id -> Int -> Bool

589

isCheapApp fn n_val_args

590

= isDataConWorkId fn

591

|| n_val_args < idArity fn

592

593

isExpandableApp :: Id -> Int -> Bool

594

isExpandableApp fn n_val_args

595

= isConLikeId fn

596

|| n_val_args < idArity fn

597

|| go n_val_args (idType fn)

598

where

599

-- See if all the arguments are PredTys (implicit params or classes)

600

-- If so we'll regard it as expandable; see Note [Expandable overloadings]

601

go 0 _ = True

602

go n_val_args ty

603

| Just (_, ty) <- splitForAllTy_maybe ty = go n_val_args ty

604

| Just (arg, ty) <- splitFunTy_maybe ty

605

, isPredTy arg = go (n_val_args-1) ty

606

| otherwise = False

607

\end{code}

608

609

Note [Expandable overloadings]

610

~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

611

Suppose the user wrote this

612

{-# RULE forall x. foo (negate x) = h x #-}

613

f x = ....(foo (negate x))....

614

He'd expect the rule to fire. But since negate is overloaded, we might

615

get this:

616

f = \d -> let n = negate d in \x -> ...foo (n x)...

617

So we treat the application of a function (negate in this case) to a

618

*dictionary* as expandable. In effect, every function is CONLIKE when

619

it's applied only to dictionaries.

620

621

622

%************************************************************************

623

%* *

624

exprOkForSpeculation

625

%* *

626

%************************************************************************

627

628

\begin{code}

629

-- | 'exprOkForSpeculation' returns True of an expression that is:

630

631

-- * Safe to evaluate even if normal order eval might not

632

-- evaluate the expression at all, or

633

634

-- * Safe /not/ to evaluate even if normal order would do so

635

636

-- Precisely, it returns @True@ iff:

637

638

-- * The expression guarantees to terminate,

639

-- * soon,

640

-- * without raising an exception,

641

-- * without causing a side effect (e.g. writing a mutable variable)

642

643

-- Note that if @exprIsHNF e@, then @exprOkForSpecuation e@.

644

-- As an example of the considerations in this test, consider:

645

646

-- > let x = case y# +# 1# of { r# -> I# r# }

647

-- > in E

648

649

-- being translated to:

650

651

-- > case y# +# 1# of { r# ->

652

-- > let x = I# r#

653

-- > in E

654

-- > }

655

656

-- We can only do this if the @y + 1@ is ok for speculation: it has no

657

-- side effects, and can't diverge or raise an exception.

658

exprOkForSpeculation :: CoreExpr -> Bool

659

exprOkForSpeculation (Lit _) = True

660

exprOkForSpeculation (Type _) = True

661

-- Tick boxes are *not* suitable for speculation

662

exprOkForSpeculation (Var v) = isUnLiftedType (idType v)

663

&& not (isTickBoxOp v)

664

exprOkForSpeculation (Note _ e) = exprOkForSpeculation e

665

exprOkForSpeculation (Cast e _) = exprOkForSpeculation e

666

667

exprOkForSpeculation (Case e _ _ alts)

668

= exprOkForSpeculation e -- Note [exprOkForSpeculation: case expressions]

669

&& all (\(_,_,rhs) -> exprOkForSpeculation rhs) alts

670

671

exprOkForSpeculation other_expr

672

= case collectArgs other_expr of

673

(Var f, args) | f `hasKey` absentErrorIdKey -- Note [Absent error Id]

674

-> all exprOkForSpeculation args -- in WwLib

675

| otherwise

676

-> spec_ok (idDetails f) args

677

_ -> False

678

679

where

680

spec_ok (DataConWorkId _) _

681

= True -- The strictness of the constructor has already

682

-- been expressed by its "wrapper", so we don't need

683

-- to take the arguments into account

684

685

spec_ok (PrimOpId op) args

686

| isDivOp op, -- Special case for dividing operations that fail

687

[arg1, Lit lit] <- args -- only if the divisor is zero

688

= not (isZeroLit lit) && exprOkForSpeculation arg1

689

-- Often there is a literal divisor, and this

690

-- can get rid of a thunk in an inner looop

691

692

| otherwise

693

= primOpOkForSpeculation op &&

694

all exprOkForSpeculation args

695

-- A bit conservative: we don't really need

696

-- to care about lazy arguments, but this is easy

697

698

spec_ok (DFunId new_type) _ = not new_type

699

-- DFuns terminate, unless the dict is implemented with a newtype

700

-- in which case they may not

701

702

spec_ok _ _ = False

703

704

-- | True of dyadic operators that can fail only if the second arg is zero!

705

isDivOp :: PrimOp -> Bool

706

-- This function probably belongs in PrimOp, or even in

707

-- an automagically generated file.. but it's such a

708

-- special case I thought I'd leave it here for now.

709

isDivOp IntQuotOp = True

710

isDivOp IntRemOp = True

711

isDivOp WordQuotOp = True

712

isDivOp WordRemOp = True

713

isDivOp FloatDivOp = True

714

isDivOp DoubleDivOp = True

715

isDivOp _ = False

716

\end{code}

717

718

Note [exprOkForSpeculation: case expressions]

719

~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

720

721

It's always sound for exprOkForSpeculation to return False, and we

722

don't want it to take too long, so it bales out on complicated-looking

723

terms. Notably lets, which can be stacked very deeply; and in any

724

case the argument of exprOkForSpeculation is usually in a strict context,

725

so any lets will have been floated away.

726

727

However, we keep going on case-expressions. An example like this one

728

showed up in DPH code:

729

foo :: Int -> Int

730

foo 0 = 0

731

foo n = (if n < 5 then 1 else 2) `seq` foo (n-1)

732

733

If exprOkForSpeculation doesn't look through case expressions, you get this:

734

T.$wfoo =

735

\ (ww :: GHC.Prim.Int#) ->

736

case ww of ds {

737

__DEFAULT -> case (case <# ds 5 of _ {

738

GHC.Bool.False -> lvl1;

739

GHC.Bool.True -> lvl})

740

of _ { __DEFAULT ->

741

T.$wfoo (GHC.Prim.-# ds_XkE 1) };

742

0 -> 0

743

}

744

745

The inner case is redundant, and should be nuked.

746

747

748

%************************************************************************

749

%* *

750

exprIsHNF, exprIsConLike

751

%* *

752

%************************************************************************

753

754

\begin{code}

755

-- Note [exprIsHNF] See also Note [exprIsCheap and exprIsHNF]

756

-- ~~~~~~~~~~~~~~~~

757

-- | exprIsHNF returns true for expressions that are certainly /already/

758

-- evaluated to /head/ normal form. This is used to decide whether it's ok

759

-- to change:

760

761

-- > case x of _ -> e

762

763

-- into:

764

765

-- > e

766

767

-- and to decide whether it's safe to discard a 'seq'.

768

769

-- So, it does /not/ treat variables as evaluated, unless they say they are.

770

-- However, it /does/ treat partial applications and constructor applications

771

-- as values, even if their arguments are non-trivial, provided the argument

772

-- type is lifted. For example, both of these are values:

773

774

-- > (:) (f x) (map f xs)

775

-- > map (...redex...)

776

777

-- because 'seq' on such things completes immediately.

778

779

-- For unlifted argument types, we have to be careful:

780

781

-- > C (f x :: Int#)

782

783

-- Suppose @f x@ diverges; then @C (f x)@ is not a value. However this can't

784

-- happen: see "CoreSyn#let_app_invariant". This invariant states that arguments of

785

-- unboxed type must be ok-for-speculation (or trivial).

786

exprIsHNF :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP

787

exprIsHNF = exprIsHNFlike isDataConWorkId isEvaldUnfolding

788

\end{code}

789

790

\begin{code}

791

-- | Similar to 'exprIsHNF' but includes CONLIKE functions as well as

792

-- data constructors. Conlike arguments are considered interesting by the

793

-- inliner.

794

exprIsConLike :: CoreExpr -> Bool -- True => lambda, conlike, PAP

795

exprIsConLike = exprIsHNFlike isConLikeId isConLikeUnfolding

796

797

-- | Returns true for values or value-like expressions. These are lambdas,

798

-- constructors / CONLIKE functions (as determined by the function argument)

799

-- or PAPs.

800

801

exprIsHNFlike :: (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool

802

exprIsHNFlike is_con is_con_unf = is_hnf_like

803

where

804

is_hnf_like (Var v) -- NB: There are no value args at this point

805

= is_con v -- Catches nullary constructors,

806

-- so that [] and () are values, for example

807

|| idArity v > 0 -- Catches (e.g.) primops that don't have unfoldings

808

|| is_con_unf (idUnfolding v)

809

-- Check the thing's unfolding; it might be bound to a value

810

-- We don't look through loop breakers here, which is a bit conservative

811

-- but otherwise I worry that if an Id's unfolding is just itself,

812

-- we could get an infinite loop

813

814

is_hnf_like (Lit _) = True

815

is_hnf_like (Type _) = True -- Types are honorary Values;

816

-- we don't mind copying them

817

is_hnf_like (Lam b e) = isRuntimeVar b || is_hnf_like e

818

is_hnf_like (Note _ e) = is_hnf_like e

819

is_hnf_like (Cast e _) = is_hnf_like e

820

is_hnf_like (App e (Type _)) = is_hnf_like e

821

is_hnf_like (App e a) = app_is_value e [a]

822

is_hnf_like (Let _ e) = is_hnf_like e -- Lazy let(rec)s don't affect us

823

is_hnf_like _ = False

824

825

-- There is at least one value argument

826

app_is_value :: CoreExpr -> [CoreArg] -> Bool

827

app_is_value (Var fun) args

828

= idArity fun > valArgCount args -- Under-applied function

829

|| is_con fun -- or constructor-like

830

app_is_value (Note _ f) as = app_is_value f as

831

app_is_value (Cast f _) as = app_is_value f as

832

app_is_value (App f a) as = app_is_value f (a:as)

833

app_is_value _ _ = False

834

\end{code}

835

836

837

%************************************************************************

838

%* *

839

Instantiating data constructors

840

%* *

841

%************************************************************************

842

843

These InstPat functions go here to avoid circularity between DataCon and Id

844

845

\begin{code}

846

dataConRepInstPat, dataConOrigInstPat :: [Unique] -> DataCon -> [Type] -> ([TyVar], [CoVar], [Id])

847

dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([TyVar], [CoVar], [Id])

848

849

dataConRepInstPat = dataConInstPat dataConRepArgTys (repeat ((fsLit "ipv")))

850

dataConRepFSInstPat = dataConInstPat dataConRepArgTys

851

dataConOrigInstPat = dataConInstPat dc_arg_tys (repeat ((fsLit "ipv")))

852

where

853

dc_arg_tys dc = map mkPredTy (dataConEqTheta dc) ++ map mkPredTy (dataConDictTheta dc) ++ dataConOrigArgTys dc

854

-- Remember to include the existential dictionaries

855

856

dataConInstPat :: (DataCon -> [Type]) -- function used to find arg tys

857

-> [FastString] -- A long enough list of FSs to use for names

858

-> [Unique] -- An equally long list of uniques, at least one for each binder

859

-> DataCon

860

-> [Type] -- Types to instantiate the universally quantified tyvars

861

-> ([TyVar], [CoVar], [Id]) -- Return instantiated variables

862

-- dataConInstPat arg_fun fss us con inst_tys returns a triple

863

-- (ex_tvs, co_tvs, arg_ids),

864

865

-- ex_tvs are intended to be used as binders for existential type args

866

867

-- co_tvs are intended to be used as binders for coercion args and the kinds

868

-- of these vars have been instantiated by the inst_tys and the ex_tys

869

-- The co_tvs include both GADT equalities (dcEqSpec) and

870

-- programmer-specified equalities (dcEqTheta)

871

872

-- arg_ids are indended to be used as binders for value arguments,

873

-- and their types have been instantiated with inst_tys and ex_tys

874

-- The arg_ids include both dicts (dcDictTheta) and

875

-- programmer-specified arguments (after rep-ing) (deRepArgTys)

876

877

-- Example.

878

-- The following constructor T1

879

880

-- data T a where

881

-- T1 :: forall b. Int -> b -> T(a,b)

882

-- ...

883

884

-- has representation type

885

-- forall a. forall a1. forall b. (a ~ (a1,b)) =>

886

-- Int -> b -> T a

887

888

-- dataConInstPat fss us T1 (a1',b') will return

889

890

-- ([a1'', b''], [c :: (a1', b')~(a1'', b'')], [x :: Int, y :: b''])

891

892

-- where the double-primed variables are created with the FastStrings and

893

-- Uniques given as fss and us

894

dataConInstPat arg_fun fss uniqs con inst_tys

895

= (ex_bndrs, co_bndrs, arg_ids)

896

where

897

univ_tvs = dataConUnivTyVars con

898

ex_tvs = dataConExTyVars con

899

arg_tys = arg_fun con

900

eq_spec = dataConEqSpec con

901

eq_theta = dataConEqTheta con

902

eq_preds = eqSpecPreds eq_spec ++ eq_theta

903

904

n_ex = length ex_tvs

905

n_co = length eq_preds

906

907

-- split the Uniques and FastStrings

908

(ex_uniqs, uniqs') = splitAt n_ex uniqs

909

(co_uniqs, id_uniqs) = splitAt n_co uniqs'

910

911

(ex_fss, fss') = splitAt n_ex fss

912

(co_fss, id_fss) = splitAt n_co fss'

913

914

-- Make existential type variables

915

ex_bndrs = zipWith3 mk_ex_var ex_uniqs ex_fss ex_tvs

916

mk_ex_var uniq fs var = mkTyVar new_name kind

917

where

918

new_name = mkSysTvName uniq fs

919

kind = tyVarKind var

920

921

-- Make the instantiating substitution

922

subst = zipOpenTvSubst (univ_tvs ++ ex_tvs) (inst_tys ++ map mkTyVarTy ex_bndrs)

923

924

-- Make new coercion vars, instantiating kind

925

co_bndrs = zipWith3 mk_co_var co_uniqs co_fss eq_preds

926

mk_co_var uniq fs eq_pred = mkCoVar new_name co_kind

927

where

928

new_name = mkSysTvName uniq fs

929

co_kind = substTy subst (mkPredTy eq_pred)

930

931

-- make value vars, instantiating types

932

mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (substTy subst ty) noSrcSpan

933

arg_ids = zipWith3 mk_id_var id_uniqs id_fss arg_tys

934

935

\end{code}

936

937

%************************************************************************

938

%* *

939

Equality

940

%* *

941

%************************************************************************

942

943

\begin{code}

944

-- | A cheap equality test which bales out fast!

945

-- If it returns @True@ the arguments are definitely equal,

946

-- otherwise, they may or may not be equal.

947

948

-- See also 'exprIsBig'

949

cheapEqExpr :: Expr b -> Expr b -> Bool

950

951

cheapEqExpr (Var v1) (Var v2) = v1==v2

952

cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2

953

cheapEqExpr (Type t1) (Type t2) = t1 `coreEqType` t2

954

955

cheapEqExpr (App f1 a1) (App f2 a2)

956

= f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2

957

958

cheapEqExpr (Cast e1 t1) (Cast e2 t2)

959

= e1 `cheapEqExpr` e2 && t1 `coreEqCoercion` t2

960

961

cheapEqExpr _ _ = False

962

\end{code}

963

964

\begin{code}

965

exprIsBig :: Expr b -> Bool

966

-- ^ Returns @True@ of expressions that are too big to be compared by 'cheapEqExpr'

967

exprIsBig (Lit _) = False

968

exprIsBig (Var _) = False

969

exprIsBig (Type _) = False

970

exprIsBig (Lam _ e) = exprIsBig e

971

exprIsBig (App f a) = exprIsBig f || exprIsBig a

972

exprIsBig (Cast e _) = exprIsBig e -- Hopefully coercions are not too big!

973

exprIsBig _ = True

974

\end{code}

975

976

\begin{code}

977

eqExpr :: InScopeSet -> CoreExpr -> CoreExpr -> Bool

978

-- Compares for equality, modulo alpha

979

eqExpr in_scope e1 e2

980

= eqExprX id_unf (mkRnEnv2 in_scope) e1 e2

981

where

982

id_unf _ = noUnfolding -- Don't expand

983

\end{code}

984

985

\begin{code}

986

eqExprX :: IdUnfoldingFun -> RnEnv2 -> CoreExpr -> CoreExpr -> Bool

987

-- ^ Compares expressions for equality, modulo alpha.

988

-- Does /not/ look through newtypes or predicate types

989

-- Used in rule matching, and also CSE

990

991

eqExprX id_unfolding_fun env e1 e2

992

= go env e1 e2

993

where

994

go env (Var v1) (Var v2)

995

| rnOccL env v1 == rnOccR env v2

996

= True

997

998

-- The next two rules expand non-local variables

999

-- C.f. Note [Expanding variables] in Rules.lhs

1000

-- and Note [Do not expand locally-bound variables] in Rules.lhs

1001

go env (Var v1) e2

1002

| not (locallyBoundL env v1)

1003

, Just e1' <- expandUnfolding_maybe (id_unfolding_fun (lookupRnInScope env v1))

1004

= go (nukeRnEnvL env) e1' e2

1005

1006

go env e1 (Var v2)

1007

| not (locallyBoundR env v2)

1008

, Just e2' <- expandUnfolding_maybe (id_unfolding_fun (lookupRnInScope env v2))

1009

= go (nukeRnEnvR env) e1 e2'

1010

1011

go _ (Lit lit1) (Lit lit2) = lit1 == lit2

1012

go env (Type t1) (Type t2) = tcEqTypeX env t1 t2

1013

go env (Cast e1 co1) (Cast e2 co2) = tcEqTypeX env co1 co2 && go env e1 e2

1014

go env (App f1 a1) (App f2 a2) = go env f1 f2 && go env a1 a2

1015

go env (Note n1 e1) (Note n2 e2) = go_note n1 n2 && go env e1 e2

1016

1017

go env (Lam b1 e1) (Lam b2 e2)

1018

= tcEqTypeX env (varType b1) (varType b2) -- False for Id/TyVar combination

1019

&& go (rnBndr2 env b1 b2) e1 e2

1020

1021

go env (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2)

1022

= go env r1 r2 -- No need to check binder types, since RHSs match

1023

&& go (rnBndr2 env v1 v2) e1 e2

1024

1025

go env (Let (Rec ps1) e1) (Let (Rec ps2) e2)

1026

= all2 (go env') rs1 rs2 && go env' e1 e2

1027

where

1028

(bs1,rs1) = unzip ps1

1029

(bs2,rs2) = unzip ps2

1030

env' = rnBndrs2 env bs1 bs2

1031

1032

go env (Case e1 b1 _ a1) (Case e2 b2 _ a2)

1033

= go env e1 e2

1034

&& tcEqTypeX env (idType b1) (idType b2)

1035

&& all2 (go_alt (rnBndr2 env b1 b2)) a1 a2

1036

1037

go _ _ _ = False

1038

1039

-----------

1040

go_alt env (c1, bs1, e1) (c2, bs2, e2)

1041

= c1 == c2 && go (rnBndrs2 env bs1 bs2) e1 e2

1042

1043

-----------

1044

go_note (SCC cc1) (SCC cc2) = cc1 == cc2

1045

go_note (CoreNote s1) (CoreNote s2) = s1 == s2

1046

go_note _ _ = False

1047

\end{code}

1048

1049

Auxiliary functions

1050

1051

\begin{code}

1052

locallyBoundL, locallyBoundR :: RnEnv2 -> Var -> Bool

1053

locallyBoundL rn_env v = inRnEnvL rn_env v

1054

locallyBoundR rn_env v = inRnEnvR rn_env v

1055

\end{code}

1056

1057

1058

%************************************************************************

1059

%* *

1060

\subsection{The size of an expression}

1061

%* *

1062

%************************************************************************

1063

1064

\begin{code}

1065

coreBindsSize :: [CoreBind] -> Int

1066

coreBindsSize bs = foldr ((+) . bindSize) 0 bs

1067

1068

exprSize :: CoreExpr -> Int

1069

-- ^ A measure of the size of the expressions, strictly greater than 0

1070

-- It also forces the expression pretty drastically as a side effect

1071

exprSize (Var v) = v `seq` 1

1072

exprSize (Lit lit) = lit `seq` 1

1073

exprSize (App f a) = exprSize f + exprSize a

1074

exprSize (Lam b e) = varSize b + exprSize e

1075

exprSize (Let b e) = bindSize b + exprSize e

1076

exprSize (Case e b t as) = seqType t `seq` exprSize e + varSize b + 1 + foldr ((+) . altSize) 0 as

1077

exprSize (Cast e co) = (seqType co `seq` 1) + exprSize e

1078

exprSize (Note n e) = noteSize n + exprSize e

1079

exprSize (Type t) = seqType t `seq` 1

1080

1081

noteSize :: Note -> Int

1082

noteSize (SCC cc) = cc `seq` 1

1083

noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations

1084

1085

varSize :: Var -> Int

1086

varSize b | isTyCoVar b = 1

1087

| otherwise = seqType (idType b) `seq`

1088

megaSeqIdInfo (idInfo b) `seq`

1089

1090

1091

varsSize :: [Var] -> Int

1092

varsSize = sum . map varSize

1093

1094

bindSize :: CoreBind -> Int

1095

bindSize (NonRec b e) = varSize b + exprSize e

1096

bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs

1097

1098

pairSize :: (Var, CoreExpr) -> Int

1099

pairSize (b,e) = varSize b + exprSize e

1100

1101

altSize :: CoreAlt -> Int

1102

altSize (c,bs,e) = c `seq` varsSize bs + exprSize e

1103

\end{code}

1104

1105

1106

%************************************************************************

1107

%* *

1108

\subsection{Hashing}

1109

%* *

1110

%************************************************************************

1111

1112

\begin{code}

1113

hashExpr :: CoreExpr -> Int

1114

-- ^ Two expressions that hash to the same @Int@ may be equal (but may not be)

1115

-- Two expressions that hash to the different Ints are definitely unequal.

1116

1117

-- The emphasis is on a crude, fast hash, rather than on high precision.

1118

1119

-- But unequal here means \"not identical\"; two alpha-equivalent

1120

-- expressions may hash to the different Ints.

1121

1122

-- We must be careful that @\\x.x@ and @\\y.y@ map to the same hash code,

1123

-- (at least if we want the above invariant to be true).

1124

1125

hashExpr e = fromIntegral (hash_expr (1,emptyVarEnv) e .&. 0x7fffffff)

1126

-- UniqFM doesn't like negative Ints

1127

1128

type HashEnv = (Int, VarEnv Int) -- Hash code for bound variables

1129

1130

hash_expr :: HashEnv -> CoreExpr -> Word32

1131

-- Word32, because we're expecting overflows here, and overflowing

1132

-- signed types just isn't cool. In C it's even undefined.

1133

hash_expr env (Note _ e) = hash_expr env e

1134

hash_expr env (Cast e _) = hash_expr env e

1135

hash_expr env (Var v) = hashVar env v

1136

hash_expr _ (Lit lit) = fromIntegral (hashLiteral lit)

1137

hash_expr env (App f e) = hash_expr env f * fast_hash_expr env e

1138

hash_expr env (Let (NonRec b r) e) = hash_expr (extend_env env b) e * fast_hash_expr env r

1139

hash_expr env (Let (Rec ((b,_):_)) e) = hash_expr (extend_env env b) e

1140

hash_expr env (Case e _ _ _) = hash_expr env e

1141

hash_expr env (Lam b e) = hash_expr (extend_env env b) e

1142

hash_expr _ (Type _) = WARN(True, text "hash_expr: type") 1

1143

-- Shouldn't happen. Better to use WARN than trace, because trace

1144

-- prevents the CPR optimisation kicking in for hash_expr.

1145

1146

fast_hash_expr :: HashEnv -> CoreExpr -> Word32

1147

fast_hash_expr env (Var v) = hashVar env v

1148

fast_hash_expr env (Type t) = fast_hash_type env t

1149

fast_hash_expr _ (Lit lit) = fromIntegral (hashLiteral lit)

1150

fast_hash_expr env (Cast e _) = fast_hash_expr env e

1151

fast_hash_expr env (Note _ e) = fast_hash_expr env e

1152

fast_hash_expr env (App _ a) = fast_hash_expr env a -- A bit idiosyncratic ('a' not 'f')!

1153

fast_hash_expr _ _ = 1

1154

1155

fast_hash_type :: HashEnv -> Type -> Word32

1156

fast_hash_type env ty

1157

| Just tv <- getTyVar_maybe ty = hashVar env tv

1158

| Just (tc,tys) <- splitTyConApp_maybe ty = let hash_tc = fromIntegral (hashName (tyConName tc))

1159

in foldr (\t n -> fast_hash_type env t + n) hash_tc tys

1160

| otherwise = 1

1161

1162

extend_env :: HashEnv -> Var -> (Int, VarEnv Int)

1163

extend_env (n,env) b = (n+1, extendVarEnv env b n)

1164

1165

hashVar :: HashEnv -> Var -> Word32

1166

hashVar (_,env) v

1167

= fromIntegral (lookupVarEnv env v `orElse` hashName (idName v))

1168

\end{code}

1169

1170

1171

%************************************************************************

1172

%* *

1173

Eta reduction

1174

%* *

1175

%************************************************************************

1176

1177

Note [Eta reduction conditions]

1178

~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

1179

We try for eta reduction here, but *only* if we get all the way to an

1180

trivial expression. We don't want to remove extra lambdas unless we

1181

are going to avoid allocating this thing altogether.

1182

1183

There are some particularly delicate points here:

1184

1185

* Eta reduction is not valid in general:

1186

\x. bot /= bot

1187

This matters, partly for old-fashioned correctness reasons but,

1188

worse, getting it wrong can yield a seg fault. Consider

1189

f = \x.f x

1190

h y = case (case y of { True -> f `seq` True; False -> False }) of

1191

True -> ...; False -> ...

1192

1193

If we (unsoundly) eta-reduce f to get f=f, the strictness analyser

1194

says f=bottom, and replaces the (f `seq` True) with just

1195

(f `cast` unsafe-co). BUT, as thing stand, 'f' got arity 1, and it

1196

*keeps* arity 1 (perhaps also wrongly). So CorePrep eta-expands

1197

the definition again, so that it does not termninate after all.

1198

Result: seg-fault because the boolean case actually gets a function value.

1199

See Trac #1947.

1200

1201

So it's important to to the right thing.

1202

1203

* Note [Arity care]: we need to be careful if we just look at f's

1204

arity. Currently (Dec07), f's arity is visible in its own RHS (see

1205

Note [Arity robustness] in SimplEnv) so we must *not* trust the

1206

arity when checking that 'f' is a value. Otherwise we will

1207

eta-reduce

1208

f = \x. f x

1209

1210

f = f

1211

Which might change a terminiating program (think (f `seq` e)) to a

1212

non-terminating one. So we check for being a loop breaker first.

1213

1214

However for GlobalIds we can look at the arity; and for primops we

1215

must, since they have no unfolding.

1216

1217

* Regardless of whether 'f' is a value, we always want to

1218

reduce (/\a -> f a) to f

1219

This came up in a RULE: foldr (build (/\a -> g a))

1220

did not match foldr (build (/\b -> ...something complex...))

1221

The type checker can insert these eta-expanded versions,

1222

with both type and dictionary lambdas; hence the slightly

1223

ad-hoc isDictId

1224

1225

* Never *reduce* arity. For example

1226

f = \xy. g x y

1227

Then if h has arity 1 we don't want to eta-reduce because then

1228

f's arity would decrease, and that is bad

1229

1230

These delicacies are why we don't use exprIsTrivial and exprIsHNF here.

1231

Alas.

1232

1233

Note [Eta reduction with casted arguments]

1234

~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

1235

Consider

1236

(\(x:t3). f (x |> g)) :: t3 -> t2

1237

where

1238

f :: t1 -> t2

1239

g :: t3 ~ t1

1240

This should be eta-reduced to

1241

1242

f |> (sym g -> t2)

1243

1244

So we need to accumulate a coercion, pushing it inward (past

1245

variable arguments only) thus:

1246

f (x |> co_arg) |> co --> (f |> (sym co_arg -> co)) x

1247

f (x:t) |> co --> (f |> (t -> co)) x

1248

f @ a |> co --> (f |> (forall a.co)) @ a

1249

f @ (g:t1~t2) |> co --> (f |> (t1~t2 => co)) @ (g:t1~t2)

1250

These are the equations for ok_arg.

1251

1252

It's true that we could also hope to eta reduce these:

1253

(\xy. (f x |> g) y)

1254

(\xy. (f x y) |> g)

1255

But the simplifier pushes those casts outwards, so we don't

1256

need to address that here.

1257

1258

\begin{code}

1259

tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr

1260

tryEtaReduce bndrs body

1261

= go (reverse bndrs) body (IdCo (exprType body))

1262

where

1263

incoming_arity = count isId bndrs

1264

1265

go :: [Var] -- Binders, innermost first, types [a3,a2,a1]

1266

-> CoreExpr -- Of type tr

1267

-> CoercionI -- Of type tr ~ ts

1268

-> Maybe CoreExpr -- Of type a1 -> a2 -> a3 -> ts

1269

-- See Note [Eta reduction with casted arguments]

1270

-- for why we have an accumulating coercion

1271

go [] fun co

1272

| ok_fun fun = Just (mkCoerceI co fun)

1273

1274

go (b : bs) (App fun arg) co

1275

| Just co' <- ok_arg b arg co

1276

= go bs fun co'

1277

1278

go _ _ _ = Nothing -- Failure!

1279

1280

---------------

1281

-- Note [Eta reduction conditions]

1282

ok_fun (App fun (Type ty))

1283

| not (any (`elemVarSet` tyVarsOfType ty) bndrs)

1284

= ok_fun fun

1285

ok_fun (Var fun_id)

1286

= not (fun_id `elem` bndrs)

1287

&& (ok_fun_id fun_id || all ok_lam bndrs)

1288

ok_fun _fun = False

1289

1290

---------------

1291

ok_fun_id fun = fun_arity fun >= incoming_arity

1292

1293

---------------

1294

fun_arity fun -- See Note [Arity care]

1295

| isLocalId fun && isLoopBreaker (idOccInfo fun) = 0

1296

| otherwise = idArity fun

1297

1298

---------------

1299

ok_lam v = isTyCoVar v || isDictId v

1300

1301

---------------

1302

ok_arg :: Var -- Of type bndr_t

1303

-> CoreExpr -- Of type arg_t

1304

-> CoercionI -- Of kind (t1~t2)

1305

-> Maybe CoercionI -- Of type (arg_t -> t1 ~ bndr_t -> t2)

1306

-- (and similarly for tyvars, coercion args)

1307

-- See Note [Eta reduction with casted arguments]

1308

ok_arg bndr (Type ty) co

1309

| Just tv <- getTyVar_maybe ty

1310

, bndr == tv = Just (mkForAllTyCoI tv co)

1311

ok_arg bndr (Var v) co

1312

| bndr == v = Just (mkFunTyCoI (IdCo (idType bndr)) co)

1313

ok_arg bndr (Cast (Var v) co_arg) co

1314

| bndr == v = Just (mkFunTyCoI (ACo (mkSymCoercion co_arg)) co)

1315

-- The simplifier combines multiple casts into one,

1316

-- so we can have a simple-minded pattern match here

1317

ok_arg _ _ _ = Nothing

1318

\end{code}

1319

1320

1321

%************************************************************************

1322

%* *

1323

\subsection{Determining non-updatable right-hand-sides}

1324

%* *

1325

%************************************************************************

1326

1327

Top-level constructor applications can usually be allocated

1328

statically, but they can't if the constructor, or any of the

1329

arguments, come from another DLL (because we can't refer to static

1330

labels in other DLLs).

1331

1332

If this happens we simply make the RHS into an updatable thunk,

1333

and 'execute' it rather than allocating it statically.

1334

1335

\begin{code}

1336

-- | This function is called only on *top-level* right-hand sides.

1337

-- Returns @True@ if the RHS can be allocated statically in the output,

1338

-- with no thunks involved at all.

1339

rhsIsStatic :: (Name -> Bool) -> CoreExpr -> Bool

1340

-- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or

1341

-- refers to, CAFs; (ii) in CoreToStg to decide whether to put an

1342

-- update flag on it and (iii) in DsExpr to decide how to expand

1343

-- list literals

1344

1345

-- The basic idea is that rhsIsStatic returns True only if the RHS is

1346

-- (a) a value lambda

1347

-- (b) a saturated constructor application with static args

1348

1349

-- BUT watch out for

1350

-- (i) Any cross-DLL references kill static-ness completely

1351

-- because they must be 'executed' not statically allocated

1352

-- ("DLL" here really only refers to Windows DLLs, on other platforms,

1353

-- this is not necessary)

1354

1355

-- (ii) We treat partial applications as redexes, because in fact we

1356

-- make a thunk for them that runs and builds a PAP

1357

-- at run-time. The only appliations that are treated as

1358

-- static are *saturated* applications of constructors.

1359

1360

-- We used to try to be clever with nested structures like this:

1361

-- ys = (:) w ((:) w [])

1362

-- on the grounds that CorePrep will flatten ANF-ise it later.

1363

-- But supporting this special case made the function much more

1364

-- complicated, because the special case only applies if there are no

1365

-- enclosing type lambdas:

1366

-- ys = /\ a -> Foo (Baz ([] a))

1367

-- Here the nested (Baz []) won't float out to top level in CorePrep.

1368

1369

-- But in fact, even without -O, nested structures at top level are

1370

-- flattened by the simplifier, so we don't need to be super-clever here.

1371

1372

-- Examples

1373

1374

-- f = \x::Int. x+7 TRUE

1375

-- p = (True,False) TRUE

1376

1377

-- d = (fst p, False) FALSE because there's a redex inside

1378

-- (this particular one doesn't happen but...)

1379

1380

-- h = D# (1.0## /## 2.0##) FALSE (redex again)

1381

-- n = /\a. Nil a TRUE

1382

1383

-- t = /\a. (:) (case w a of ...) (Nil a) FALSE (redex)

1384

1385

1386

-- This is a bit like CoreUtils.exprIsHNF, with the following differences:

1387

-- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)

1388

1389

-- b) (C x xs), where C is a contructor is updatable if the application is

1390

-- dynamic

1391

1392

-- c) don't look through unfolding of f in (f x).

1393

1394

rhsIsStatic _is_dynamic_name rhs = is_static False rhs

1395

where

1396

is_static :: Bool -- True <=> in a constructor argument; must be atomic

1397

-> CoreExpr -> Bool

1398

1399

is_static False (Lam b e) = isRuntimeVar b || is_static False e

1400

is_static in_arg (Note n e) = notSccNote n && is_static in_arg e

1401

is_static in_arg (Cast e _) = is_static in_arg e

1402

1403

is_static _ (Lit lit)

1404

= case lit of

1405

MachLabel _ _ _ -> False

1406

_ -> True

1407

-- A MachLabel (foreign import "&foo") in an argument

1408

-- prevents a constructor application from being static. The

1409

-- reason is that it might give rise to unresolvable symbols

1410

-- in the object file: under Linux, references to "weak"

1411

-- symbols from the data segment give rise to "unresolvable

1412

-- relocation" errors at link time This might be due to a bug

1413

-- in the linker, but we'll work around it here anyway.

1414

-- SDM 24/2/2004

1415

1416

is_static in_arg other_expr = go other_expr 0

1417

where

1418

go (Var f) n_val_args

1419

#if mingw32_TARGET_OS

1420

| not (_is_dynamic_name (idName f))

1421

#endif

1422

= saturated_data_con f n_val_args

1423

|| (in_arg && n_val_args == 0)

1424

-- A naked un-applied variable is *not* deemed a static RHS

1425

-- E.g. f = g

1426

-- Reason: better to update so that the indirection gets shorted

1427

-- out, and the true value will be seen

1428

-- NB: if you change this, you'll break the invariant that THUNK_STATICs

1429

-- are always updatable. If you do so, make sure that non-updatable

1430

-- ones have enough space for their static link field!

1431

1432

go (App f a) n_val_args

1433

| isTypeArg a = go f n_val_args

1434

| not in_arg && is_static True a = go f (n_val_args + 1)

1435

-- The (not in_arg) checks that we aren't in a constructor argument;

1436

-- if we are, we don't allow (value) applications of any sort

1437

1438

-- NB. In case you wonder, args are sometimes not atomic. eg.

1439

-- x = D# (1.0## /## 2.0##)

1440

-- can't float because /## can fail.

1441

1442

go (Note n f) n_val_args = notSccNote n && go f n_val_args

1443

go (Cast e _) n_val_args = go e n_val_args

1444

go _ _ = False

1445

1446

saturated_data_con f n_val_args

1447

= case isDataConWorkId_maybe f of

1448

Just dc -> n_val_args == dataConRepArity dc

1449

Nothing -> False

1450

\end{code}

Older »