Specialise.lhs 84.4 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
3
4
5
6
%
\section[Specialise]{Stamping out overloading, and (optionally) polymorphism}

\begin{code}
7
{-# LANGUAGE CPP #-}
8
module Specialise ( specProgram, specUnfolding ) where
9

10
#include "HsVersions.h"
11

12
import Id
13
import TcType hiding( substTy, extendTvSubstList )
14
import Type   hiding( substTy, extendTvSubstList )
15
import Coercion( Coercion )
16
import Module( Module )
17
import CoreMonad
18
import qualified CoreSubst
19
import CoreUnfold
20
21
import VarSet
import VarEnv
22
import CoreSyn
23
import Rules
24
import PprCore          ( pprParendExpr )
25
26
import CoreUtils        ( exprIsTrivial, applyTypeToArgs )
import CoreFVs          ( exprFreeVars, exprsFreeVars, idFreeVars )
27
import UniqSupply
28
import Name
29
import MkId             ( voidArgId, voidPrimId )
30
31
import Maybes           ( catMaybes, isJust )
import BasicTypes
32
import HscTypes
33
import Bag
34
import DynFlags
Ian Lynagh's avatar
Ian Lynagh committed
35
import Util
36
import Outputable
37
import FastString
38
import State
39

Austin Seipp's avatar
Austin Seipp committed
40
import Control.Applicative (Applicative(..))
41
import Control.Monad
42
43
44
import Data.Map (Map)
import qualified Data.Map as Map
import qualified FiniteMap as Map
45
46
47
\end{code}

%************************************************************************
48
%*                                                                      *
49
\subsection[notes-Specialise]{Implementation notes [SLPJ, Aug 18 1993]}
50
%*                                                                      *
51
52
53
%************************************************************************

These notes describe how we implement specialisation to eliminate
sof's avatar
sof committed
54
overloading.
55

sof's avatar
sof committed
56
The specialisation pass works on Core
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
syntax, complete with all the explicit dictionary application,
abstraction and construction as added by the type checker.  The
existing type checker remains largely as it is.

One important thought: the {\em types} passed to an overloaded
function, and the {\em dictionaries} passed are mutually redundant.
If the same function is applied to the same type(s) then it is sure to
be applied to the same dictionary(s)---or rather to the same {\em
values}.  (The arguments might look different but they will evaluate
to the same value.)

Second important thought: we know that we can make progress by
treating dictionary arguments as static and worth specialising on.  So
we can do without binding-time analysis, and instead specialise on
dictionary arguments and no others.

The basic idea
~~~~~~~~~~~~~~
Suppose we have

77
78
        let f = <f_rhs>
        in <body>
79

80
and suppose f is overloaded.
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97

STEP 1: CALL-INSTANCE COLLECTION

We traverse <body>, accumulating all applications of f to types and
dictionaries.

(Might there be partial applications, to just some of its types and
dictionaries?  In principle yes, but in practice the type checker only
builds applications of f to all its types and dictionaries, so partial
applications could only arise as a result of transformation, and even
then I think it's unlikely.  In any case, we simply don't accumulate such
partial applications.)


STEP 2: EQUIVALENCES

So now we have a collection of calls to f:
98
99
100
        f t1 t2 d1 d2
        f t3 t4 d3 d4
        ...
101
102
103
104
105
106
107
108
109
110
111
Notice that f may take several type arguments.  To avoid ambiguity, we
say that f is called at type t1/t2 and t3/t4.

We take equivalence classes using equality of the *types* (ignoring
the dictionary args, which as mentioned previously are redundant).

STEP 3: SPECIALISATION

For each equivalence class, choose a representative (f t1 t2 d1 d2),
and create a local instance of f, defined thus:

112
        f@t1/t2 = <f_rhs> t1 t2 d1 d2
113

sof's avatar
sof committed
114
115
116
117
118
119
f_rhs presumably has some big lambdas and dictionary lambdas, so lots
of simplification will now result.  However we don't actually *do* that
simplification.  Rather, we leave it for the simplifier to do.  If we
*did* do it, though, we'd get more call instances from the specialised
RHS.  We can work out what they are by instantiating the call-instance
set from f's RHS with the types t1, t2.
120
121
122
123
124
125
126
127
128
129

Add this new id to f's IdInfo, to record that f has a specialised version.

Before doing any of this, check that f's IdInfo doesn't already
tell us about an existing instance of f at the required type/s.
(This might happen if specialisation was applied more than once, or
it might arise from user SPECIALIZE pragmas.)

Recursion
~~~~~~~~~
130
Wait a minute!  What if f is recursive?  Then we can't just plug in
131
132
133
134
135
its right-hand side, can we?

But it's ok.  The type checker *always* creates non-recursive definitions
for overloaded recursive functions.  For example:

136
        f x = f (x+x)           -- Yes I know its silly
137
138
139

becomes

140
141
142
143
144
        f a (d::Num a) = let p = +.sel a d
                         in
                         letrec fl (y::a) = fl (p y y)
                         in
                         fl
145

sof's avatar
sof committed
146
147
We still have recusion for non-overloaded functions which we
speciailise, but the recursive call should get specialised to the
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
same recursive version.


Polymorphism 1
~~~~~~~~~~~~~~

All this is crystal clear when the function is applied to *constant
types*; that is, types which have no type variables inside.  But what if
it is applied to non-constant types?  Suppose we find a call of f at type
t1/t2.  There are two possibilities:

(a) The free type variables of t1, t2 are in scope at the definition point
of f.  In this case there's no problem, we proceed just as before.  A common
example is as follows.  Here's the Haskell:

163
164
        g y = let f x = x+x
              in f y + f y
165
166
167

After typechecking we have

168
169
        g a (d::Num a) (y::a) = let f b (d'::Num b) (x::b) = +.sel b d' x x
                                in +.sel a d (f a d y) (f a d y)
170
171
172
173

Notice that the call to f is at type type "a"; a non-constant type.
Both calls to f are at the same type, so we can specialise to give:

174
175
        g a (d::Num a) (y::a) = let f@a (x::a) = +.sel a d x x
                                in +.sel a d (f@a y) (f@a y)
176
177
178
179
180


(b) The other case is when the type variables in the instance types
are *not* in scope at the definition point of f.  The example we are
working with above is a good case.  There are two instances of (+.sel a d),
181
but "a" is not in scope at the definition of +.sel.  Can we do anything?
182
183
184
Yes, we can "common them up", a sort of limited common sub-expression deal.
This would give:

185
186
187
        g a (d::Num a) (y::a) = let +.sel@a = +.sel a d
                                    f@a (x::a) = +.sel@a x x
                                in +.sel@a (f@a y) (f@a y)
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205

This can save work, and can't be spotted by the type checker, because
the two instances of +.sel weren't originally at the same type.

Further notes on (b)

* There are quite a few variations here.  For example, the defn of
  +.sel could be floated ouside the \y, to attempt to gain laziness.
  It certainly mustn't be floated outside the \d because the d has to
  be in scope too.

* We don't want to inline f_rhs in this case, because
that will duplicate code.  Just commoning up the call is the point.

* Nothing gets added to +.sel's IdInfo.

* Don't bother unless the equivalence class has more than one item!

206
Not clear whether this is all worth it.  It is of course OK to
207
208
209
210
211
212
simply discard call-instances when passing a big lambda.

Polymorphism 2 -- Overloading
~~~~~~~~~~~~~~
Consider a function whose most general type is

213
        f :: forall a b. Ord a => [a] -> b -> b
214
215
216
217
218
219
220
221
222

There is really no point in making a version of g at Int/Int and another
at Int/Bool, because it's only instancing the type variable "a" which
buys us any efficiency. Since g is completely polymorphic in b there
ain't much point in making separate versions of g for the different
b types.

That suggests that we should identify which of g's type variables
are constrained (like "a") and which are unconstrained (like "b").
223
Then when taking equivalence classes in STEP 2, we ignore the type args
224
225
226
corresponding to unconstrained type variable.  In STEP 3 we make
polymorphic versions.  Thus:

227
        f@t1/ = /\b -> <f_rhs> t1 b d1 d2
228

sof's avatar
sof committed
229
We do this.
230
231


sof's avatar
sof committed
232
233
234
Dictionary floating
~~~~~~~~~~~~~~~~~~~
Consider this
235

236
237
238
        f a (d::Num a) = let g = ...
                         in
                         ...(let d1::Ord a = Num.Ord.sel a d in g a d1)...
239

sof's avatar
sof committed
240
241
242
243
244
Here, g is only called at one type, but the dictionary isn't in scope at the
definition point for g.  Usually the type checker would build a
definition for d1 which enclosed g, but the transformation system
might have moved d1's defn inward.  Solution: float dictionary bindings
outwards along with call instances.
245
246
247

Consider

248
249
250
251
        f x = let g p q = p==q
                  h r s = (r+s, g r s)
              in
              h x x
252
253
254
255


Before specialisation, leaving out type abstractions we have

256
257
258
259
260
261
262
        f df x = let g :: Eq a => a -> a -> Bool
                     g dg p q = == dg p q
                     h :: Num a => a -> a -> (a, Bool)
                     h dh r s = let deq = eqFromNum dh
                                in (+ dh r s, g deq r s)
              in
              h df x x
263
264
265

After specialising h we get a specialised version of h, like this:

266
267
                    h' r s = let deq = eqFromNum df
                             in (+ df r s, g deq r s)
268
269

But we can't naively make an instance for g from this, because deq is not in scope
270
at the defn of g.  Instead, we have to float out the (new) defn of deq
271
272
273
274
275
276
277
278
to widen its scope.  Notice that this floating can't be done in advance -- it only
shows up when specialisation is done.

User SPECIALIZE pragmas
~~~~~~~~~~~~~~~~~~~~~~~
Specialisation pragmas can be digested by the type checker, and implemented
by adding extra definitions along with that of f, in the same way as before

279
        f@t1/t2 = <f_rhs> t1 t2 d1 d2
280
281
282
283

Indeed the pragmas *have* to be dealt with by the type checker, because
only it knows how to build the dictionaries d1 and d2!  For example

284
285
        g :: Ord a => [a] -> [a]
        {-# SPECIALIZE f :: [Tree Int] -> [Tree Int] #-}
286
287
288
289
290
291
292
293
294
295
296

Here, the specialised version of g is an application of g's rhs to the
Ord dictionary for (Tree Int), which only the type checker can conjure
up.  There might not even *be* one, if (Tree Int) is not an instance of
Ord!  (All the other specialision has suitable dictionaries to hand
from actual calls.)

Problem.  The type checker doesn't have to hand a convenient <f_rhs>, because
it is buried in a complex (as-yet-un-desugared) binding group.
Maybe we should say

297
        f@t1/t2 = f* t1 t2 d1 d2
298
299
300
301
302
303
304
305
306

where f* is the Id f with an IdInfo which says "inline me regardless!".
Indeed all the specialisation could be done in this way.
That in turn means that the simplifier has to be prepared to inline absolutely
any in-scope let-bound thing.


Again, the pragma should permit polymorphism in unconstrained variables:

307
308
        h :: Ord a => [a] -> b -> b
        {-# SPECIALIZE h :: [Int] -> b -> b #-}
309
310
311

We *insist* that all overloaded type variables are specialised to ground types,
(and hence there can be no context inside a SPECIALIZE pragma).
312
We *permit* unconstrained type variables to be specialised to
313
314
        - a ground type
        - or left as a polymorphic type variable
315
316
but nothing in between.  So

317
        {-# SPECIALIZE h :: [Int] -> [c] -> [c] #-}
318

319
320
321
322
323
324
325
326
is *illegal*.  (It can be handled, but it adds complication, and gains the
programmer nothing.)


SPECIALISING INSTANCE DECLARATIONS
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider

327
328
329
        instance Foo a => Foo [a] where
                ...
        {-# SPECIALIZE instance Foo [Int] #-}
330
331
332
333

The original instance decl creates a dictionary-function
definition:

334
        dfun.Foo.List :: forall a. Foo a -> Foo [a]
335
336
337
338

The SPECIALIZE pragma just makes a specialised copy, just as for
ordinary function definitions:

339
340
        dfun.Foo.List@Int :: Foo [Int]
        dfun.Foo.List@Int = dfun.Foo.List Int dFooInt
341
342
343
344
345
346
347
348
349
350
351
352
353
354

The information about what instance of the dfun exist gets added to
the dfun's IdInfo in the same way as a user-defined function too.


Automatic instance decl specialisation?
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Can instance decls be specialised automatically?  It's tricky.
We could collect call-instance information for each dfun, but
then when we specialised their bodies we'd get new call-instances
for ordinary functions; and when we specialised their bodies, we might get
new call-instances of the dfuns, and so on.  This all arises because of
the unrestricted mutual recursion between instance decls and value decls.

sof's avatar
sof committed
355
356
357
Still, there's no actual problem; it just means that we may not do all
the specialisation we could theoretically do.

358
359
360
361
362
Furthermore, instance decls are usually exported and used non-locally,
so we'll want to compile enough to get those specialisations done.

Lastly, there's no such thing as a local instance decl, so we can
survive solely by spitting out *usage* information, and then reading that
363
back in as a pragma when next compiling the file.  So for now,
364
365
366
367
368
369
370
371
372
373
374
375
376
we only specialise instance decls in response to pragmas.


SPITTING OUT USAGE INFORMATION
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

To spit out usage information we need to traverse the code collecting
call-instance information for all imported (non-prelude?) functions
and data types. Then we equivalence-class it and spit it out.

This is done at the top-level when all the call instances which escape
must be for imported functions and data types.

sof's avatar
sof committed
377
378
*** Not currently done ***

379
380
381
382
383

Partial specialisation by pragmas
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
What about partial specialisation:

384
385
        k :: (Ord a, Eq b) => [a] -> b -> b -> [a]
        {-# SPECIALIZE k :: Eq b => [Int] -> b -> b -> [a] #-}
386
387
388

or even

389
        {-# SPECIALIZE k :: Eq b => [Int] -> [b] -> [b] -> [a] #-}
390
391
392

Seems quite reasonable.  Similar things could be done with instance decls:

393
394
395
396
        instance (Foo a, Foo b) => Foo (a,b) where
                ...
        {-# SPECIALIZE instance Foo a => Foo (a,Int) #-}
        {-# SPECIALIZE instance Foo b => Foo (Int,b) #-}
397
398
399
400
401
402
403
404
405
406
407

Ho hum.  Things are complex enough without this.  I pass.


Requirements for the simplifer
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The simplifier has to be able to take advantage of the specialisation.

* When the simplifier finds an application of a polymorphic f, it looks in
f's IdInfo in case there is a suitable instance to call instead.  This converts

408
        f t1 t2 d1 d2   ===>   f_t1_t2
409
410
411
412
413
414

Note that the dictionaries get eaten up too!

* Dictionary selection operations on constant dictionaries must be
  short-circuited:

415
        +.sel Int d     ===>  +Int
416
417
418
419
420
421
422
423
424
425
426

The obvious way to do this is in the same way as other specialised
calls: +.sel has inside it some IdInfo which tells that if it's applied
to the type Int then it should eat a dictionary and transform to +Int.

In short, dictionary selectors need IdInfo inside them for constant
methods.

* Exactly the same applies if a superclass dictionary is being
  extracted:

427
        Eq.sel Int d   ===>   dEqInt
428
429
430
431
432

* Something similar applies to dictionary construction too.  Suppose
dfun.Eq.List is the function taking a dictionary for (Eq a) to
one for (Eq [a]).  Then we want

433
        dfun.Eq.List Int d      ===> dEq.List_Int
434
435
436
437
438
439
440

Where does the Eq [Int] dictionary come from?  It is built in
response to a SPECIALIZE pragma on the Eq [a] instance decl.

In short, dfun Ids need IdInfo with a specialisation for each
constant instance of their instance declaration.

sof's avatar
sof committed
441
442
All this uses a single mechanism: the SpecEnv inside an Id

443
444
445
446

What does the specialisation IdInfo look like?
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

sof's avatar
sof committed
447
448
The SpecEnv of an Id maps a list of types (the template) to an expression

449
        [Type]  |->  Expr
450

451
For example, if f has this SpecInfo:
452

453
        [Int, a]  ->  \d:Ord Int. f' a
454

sof's avatar
sof committed
455
it means that we can replace the call
456

457
        f Int t  ===>  (\d. f' t)
sof's avatar
sof committed
458
459
460

This chucks one dictionary away and proceeds with the
specialised version of f, namely f'.
461
462
463
464
465
466
467


What can't be done this way?
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
There is no way, post-typechecker, to get a dictionary for (say)
Eq a from a dictionary for Eq [a].  So if we find

468
        ==.sel [t] d
469

470
we can't transform to
471

472
        eqList (==.sel t d')
473

474
where
475
        eqList :: (a->a->Bool) -> [a] -> [a] -> Bool
476
477
478
479
480
481
482
483
484

Of course, we currently have no way to automatically derive
eqList, nor to connect it to the Eq [a] instance decl, but you
can imagine that it might somehow be possible.  Taking advantage
of this is permanently ruled out.

Still, this is no great hardship, because we intend to eliminate
overloading altogether anyway!

sof's avatar
sof committed
485
486
487
488
A note about non-tyvar dictionaries
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Some Ids have types like

489
        forall a,b,c. Eq a -> Ord [a] -> tau
sof's avatar
sof committed
490
491
492
493

This seems curious at first, because we usually only have dictionary
args whose types are of the form (C a) where a is a type variable.
But this doesn't hold for the functions arising from instance decls,
Krzysztof Gogolewski's avatar
Typos    
Krzysztof Gogolewski committed
494
which sometimes get arguments with types of form (C (T a)) for some
sof's avatar
sof committed
495
496
497
498
type constructor T.

Should we specialise wrt this compound-type dictionary?  We used to say
"no", saying:
499
500
501
502
503
504
        "This is a heuristic judgement, as indeed is the fact that we
        specialise wrt only dictionaries.  We choose *not* to specialise
        wrt compound dictionaries because at the moment the only place
        they show up is in instance decls, where they are simply plugged
        into a returned dictionary.  So nothing is gained by specialising
        wrt them."
sof's avatar
sof committed
505
506

But it is simpler and more uniform to specialise wrt these dicts too;
507
and in future GHC is likely to support full fledged type signatures
sof's avatar
sof committed
508
like
509
        f :: Eq [(a,b)] => ...
sof's avatar
sof committed
510

511

512
%************************************************************************
513
%*                                                                      *
514
\subsubsection{The new specialiser}
515
%*                                                                      *
516
517
518
%************************************************************************

Our basic game plan is this.  For let(rec) bound function
519
        f :: (C a, D c) => (a,b,c,d) -> Bool
520

521
* Find any specialised calls of f, (f ts ds), where
522
523
524
525
526
  ts are the type arguments t1 .. t4, and
  ds are the dictionary arguments d1 .. d2.

* Add a new definition for f1 (say):

527
        f1 = /\ b d -> (..body of f..) t1 b t3 d d1 d2
528
529
530
531
532

  Note that we abstract over the unconstrained type arguments.

* Add the mapping

533
        [t1,b,t3,d]  |->  \d1 d2 -> f1 b d
534
535

  to the specialisations of f.  This will be used by the
536
537
  simplifier to replace calls
                (f t1 t2 t3 t4) da db
538
  by
539
                (\d1 d1 -> f1 t2 t4) da db
540
541
542
543
544
545
546
547
548
549
550
551

  All the stuff about how many dictionaries to discard, and what types
  to apply the specialised function to, are handled by the fact that the
  SpecEnv contains a template for the result of the specialisation.

We don't build *partial* specialisations for f.  For example:

  f :: Eq a => a -> a -> Bool
  {-# SPECIALISE f :: (Eq b, Eq c) => (b,c) -> (b,c) -> Bool #-}

Here, little is gained by making a specialised copy of f.
There's a distinct danger that the specialised version would
552
first build a dictionary for (Eq b, Eq c), and then select the (==)
553
554
555
556
557
558
559
method from it!  Even if it didn't, not a great deal is saved.

We do, however, generate polymorphic, but not overloaded, specialisations:

  f :: Eq a => [a] -> b -> b -> b
  {#- SPECIALISE f :: [Int] -> b -> b -> b #-}

560
Hence, the invariant is this:
561

562
        *** no specialised version is overloaded ***
563
564


565
%************************************************************************
566
%*                                                                      *
567
\subsubsection{The exported function}
568
%*                                                                      *
569
570
571
%************************************************************************

\begin{code}
Joachim Breitner's avatar
Joachim Breitner committed
572
specProgram :: ModGuts -> CoreM ModGuts
573
574
575
576
specProgram guts@(ModGuts { mg_module = this_mod
                          , mg_rules = local_rules
                          , mg_binds = binds })
  = do { dflags <- getDynFlags
577

578
             -- Specialise the bindings of this module
579
       ; (binds', uds) <- runSpecM dflags (go binds)
580

581
             -- Specialise imported functions
582
583
584
       ; hpt_rules <- getRuleBase
       ; let rule_base = extendRuleBaseList hpt_rules local_rules
       ; (new_rules, spec_binds) <- specImports dflags this_mod emptyVarSet rule_base uds
585

586
587
       ; let final_binds | null spec_binds = binds'
                         | otherwise       = Rec (flattenBinds spec_binds) : binds'
588
                   -- Note [Glom the bindings if imported functions are specialised]
589
590
591

       ; return (guts { mg_binds = final_binds
                      , mg_rules = new_rules ++ local_rules }) }
592
  where
593
594
595
596
597
        -- We need to start with a Subst that knows all the things
        -- that are in scope, so that the substitution engine doesn't
        -- accidentally re-use a unique that's already in use
        -- Easiest thing is to do it all at once, as if all the top-level
        -- decls were mutually recursive
598
599
600
    top_subst = SE { se_subst = CoreSubst.mkEmptySubst $ mkInScopeSet $ mkVarSet $
                                bindersOfBinds binds
                   , se_interesting = emptyVarSet }
601

602
603
604
605
    go []           = return ([], emptyUDs)
    go (bind:binds) = do (binds', uds) <- go binds
                         (bind', uds') <- specBind top_subst bind uds
                         return (bind' ++ binds', uds')
606

607
specImports :: DynFlags
608
            -> Module
609
            -> VarSet           -- Don't specialise these ones
610
611
612
613
                                -- See Note [Avoiding recursive specialisation]
            -> RuleBase         -- Rules from this module and the home package
                                -- (but not external packages, which can change)
            -> UsageDetails     -- Calls for imported things, and floating bindings
614
615
            -> CoreM ( [CoreRule]   -- New rules
                     , [CoreBind] ) -- Specialised bindings and floating bindings
616
specImports dflags this_mod done rule_base uds
617
  = do { let import_calls = varEnvElts (ud_calls uds)
618
       ; (rules, spec_binds) <- go rule_base import_calls
619
620
621
622
       ; return (rules, wrapDictBinds (ud_binds uds) spec_binds) }
  where
    go _ [] = return ([], [])
    go rb (CIS fn calls_for_fn : other_calls)
623
624
      = do { (rules1, spec_binds1) <- specImport dflags this_mod done rb fn $
                                      Map.toList calls_for_fn
625
626
627
           ; (rules2, spec_binds2) <- go (extendRuleBaseList rb rules1) other_calls
           ; return (rules1 ++ rules2, spec_binds1 ++ spec_binds2) }

628
specImport :: DynFlags
629
           -> Module
630
           -> VarSet                -- Don't specialise these
631
632
633
                                    -- See Note [Avoiding recursive specialisation]
           -> RuleBase              -- Rules from this module
           -> Id -> [CallInfo]      -- Imported function and calls for it
634
635
           -> CoreM ( [CoreRule]    -- New rules
                    , [CoreBind] )  -- Specialised bindings
636
specImport dflags this_mod done rb fn calls_for_fn
637
638
  | fn `elemVarSet` done
  = return ([], [])     -- No warning.  This actually happens all the time
Gabor Greif's avatar
typos    
Gabor Greif committed
639
                        -- when specialising a recursive function, because
640
641
                        -- the RHS of the specialised function contains a recursive
                        -- call to the original function
642

643
644
645
  | null calls_for_fn   -- We filtered out all the calls in deleteCallsMentioning
  = return ([], [])

646
647
  | wantSpecImport dflags unfolding
  , Just rhs <- maybeUnfoldingTemplate unfolding
648
  = do {     -- Get rules from the external package state
649
650
             -- We keep doing this in case we "page-fault in"
             -- more rules as we go along
651
       ; hsc_env <- getHscEnv
652
       ; eps <- liftIO $ hscEPS hsc_env
653
       ; let full_rb = unionRuleBase rb (eps_rule_base eps)
654
             rules_for_fn = getRules full_rb fn
655

656
       ; (rules1, spec_pairs, uds) <- runSpecM dflags $
657
              specCalls (Just this_mod) emptySpecEnv rules_for_fn calls_for_fn fn rhs
658
       ; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs]
659
660
             -- After the rules kick in we may get recursion, but
             -- we rely on a global GlomBinds to sort that out later
661
             -- See Note [Glom the bindings if imported functions are specialised]
662
663

              -- Now specialise any cascaded calls
664
665
       ; (rules2, spec_binds2) <- -- pprTrace "specImport" (ppr fn $$ ppr uds $$ ppr rhs) $
                                  specImports dflags this_mod (extendVarSet done fn)
666
667
                                                     (extendRuleBaseList rb rules1)
                                                     uds
668
669
670
671

       ; return (rules2 ++ rules1, spec_binds2 ++ spec_binds1) }

  | otherwise
672
673
674
675
  = WARN( True, hang (ptext (sLit "specImport discarding:") <+> ppr fn <+> dcolon <+> ppr (idType fn))
                   2 (  (text "want:" <+> ppr (wantSpecImport dflags unfolding))
                     $$ (text "stable:" <+> ppr (isStableUnfolding unfolding))
                     $$ (text "calls:" <+> vcat (map (pprCallInfo fn) calls_for_fn)) ) )
676
    return ([], [])
677
678
  where
    unfolding = realIdUnfolding fn   -- We want to see the unfolding even for loop breakers
679

680
wantSpecImport :: DynFlags -> Unfolding -> Bool
681
-- See Note [Specialise imported INLINABLE things]
682
683
wantSpecImport dflags unf
 = case unf of
684
685
686
687
688
689
     NoUnfolding      -> False
     OtherCon {}      -> False
     DFunUnfolding {} -> True
     CoreUnfolding { uf_src = src, uf_guidance = _guidance }
       | gopt Opt_SpecialiseAggressively dflags -> True
       | isStableSource src -> True
690
               -- Specialise even INLINE things; it hasn't inlined yet,
691
692
693
               -- so perhaps it never will.  Moreover it may have calls
               -- inside it that we want to specialise
       | otherwise -> False    -- Stable, not INLINE, hence INLINEABLE
694
695
\end{code}

696
697
Note [Specialise imported INLINABLE things]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
698
699
700
701
702
703
704
705
706
707
708
What imported functions do we specialise?  The basic set is
 * DFuns and things with INLINABLE pragmas.
but with -fspecialise-aggressively we add
 * Anything with an unfolding template

Trac #8874 has a good example of why we want to auto-specialise DFuns.

We have the -fspecialise-aggressively flag (usually off), because we
risk lots of orphan modules from over-vigorous specialisation.
However it's not a big deal: anything non-recursive with an
unfolding-template will probably have been inlined already.
709
710
711

Note [Glom the bindings if imported functions are specialised]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
712
Suppose we have an imported, *recursive*, INLINABLE function
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
   f :: Eq a => a -> a
   f = /\a \d x. ...(f a d)...
In the module being compiled we have
   g x = f (x::Int)
Now we'll make a specialised function
   f_spec :: Int -> Int
   f_spec = \x -> ...(f Int dInt)...
   {-# RULE  f Int _ = f_spec #-}
   g = \x. f Int dInt x
Note that f_spec doesn't look recursive
After rewriting with the RULE, we get
   f_spec = \x -> ...(f_spec)...
BUT since f_spec was non-recursive before it'll *stay* non-recursive.
The occurrence analyser never turns a NonRec into a Rec.  So we must
make sure that f_spec is recursive.  Easiest thing is to make all
the specialisations for imported bindings recursive.


Note [Avoiding recursive specialisation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
733
734
735
736
737
When we specialise 'f' we may find new overloaded calls to 'g', 'h' in
'f's RHS.  So we want to specialise g,h.  But we don't want to
specialise f any more!  It's possible that f's RHS might have a
recursive yet-more-specialised call, so we'd diverge in that case.
And if the call is to the same type, one specialisation is enough.
738
Avoiding this recursive specialisation loop is the reason for the
739
740
'done' VarSet passed to specImports and specImport.

741
%************************************************************************
742
%*                                                                      *
743
\subsubsection{@specExpr@: the main function}
744
%*                                                                      *
745
746
%************************************************************************

747
\begin{code}
748
749
750
751
752
753
754
data SpecEnv 
  = SE { se_subst :: CoreSubst.Subst
             -- We carry a substitution down:
             -- a) we must clone any binding that might float outwards,
             --    to avoid name clashes
             -- b) we carry a type substitution to use when analysing
             --    the RHS of specialised bindings (no type-let!)
755

756

757
758
759
760
761
762
763
764
765
766
767
768
769
       , se_interesting :: VarSet 
             -- Dict Ids that we know something about
             -- and hence may be worth specialising against
             -- See Note [Interesting dictionary arguments]
     }

emptySpecEnv :: SpecEnv
emptySpecEnv = SE { se_subst = CoreSubst.emptySubst, se_interesting = emptyVarSet} 

specVar :: SpecEnv -> Id -> CoreExpr
specVar env v = CoreSubst.lookupIdSubst (text "specVar") (se_subst env) v

specExpr :: SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
770

771
772
773
774
775
776
777
778
779
780
781
---------------- First the easy cases --------------------
specExpr env (Type ty)     = return (Type     (substTy env ty), emptyUDs)
specExpr env (Coercion co) = return (Coercion (substCo env co), emptyUDs)
specExpr env (Var v)       = return (specVar env v, emptyUDs)
specExpr _   (Lit lit)     = return (Lit lit,       emptyUDs)
specExpr env (Cast e co)
  = do { (e', uds) <- specExpr env e
       ; return ((Cast e' (substCo env co)), uds) }
specExpr env (Tick tickish body)
  = do { (body', uds) <- specExpr env body
       ; return (Tick (specTickish env tickish) body', uds) }
782
783

---------------- Applications might generate a call instance --------------------
784
specExpr env expr@(App {})
785
  = go expr []
786
  where
787
    go (App fun arg) args = do (arg', uds_arg) <- specExpr env arg
788
789
                               (fun', uds_app) <- go fun (arg':args)
                               return (App fun' arg', uds_arg `plusUDs` uds_app)
790

791
792
    go (Var f)       args = case specVar env f of
                                Var f' -> return (Var f', mkCallUDs env f' args)
793
                                e'     -> return (e', emptyUDs) -- I don't expect this!
794
    go other         _    = specExpr env other
795
796

---------------- Lambda/case require dumping of usage details --------------------
797
798
specExpr env e@(Lam _ _) = do
    (body', uds) <- specExpr env' body
799
    let (free_uds, dumped_dbs) = dumpUDs bndrs' uds
800
    return (mkLams bndrs' (wrapDictBindsE dumped_dbs body'), free_uds)
801
  where
802
    (bndrs, body) = collectBinders e
803
    (env', bndrs') = substBndrs env bndrs
804
805
        -- More efficient to collect a group of binders together all at once
        -- and we don't want to split a lambda group with dumped bindings
806

807
808
specExpr env (Case scrut case_bndr ty alts)
  = do { (scrut', scrut_uds) <- specExpr env scrut
809
       ; (scrut'', case_bndr', alts', alts_uds)
810
811
             <- specCase env scrut' case_bndr alts
       ; return (Case scrut'' case_bndr' (substTy env ty) alts'
812
                , scrut_uds `plusUDs` alts_uds) }
813
814

---------------- Finally, let is the interesting case --------------------
815
816
817
specExpr env (Let bind body)
  = do { -- Clone binders
         (rhs_env, body_env, bind') <- cloneBindSM env bind
818

819
820
         -- Deal with the body
       ; (body', body_uds) <- specExpr body_env body
821

822
        -- Deal with the bindings
823
      ; (binds', uds) <- specBind rhs_env bind' body_uds
824
825

        -- All done
826
      ; return (foldr Let body' binds', uds) }
827

828
829
830
specTickish :: SpecEnv -> Tickish Id -> Tickish Id
specTickish env (Breakpoint ix ids)
  = Breakpoint ix [ id' | id <- ids, Var id' <- [specVar env id]]
831
832
833
  -- drop vars from the list if they have a non-variable substitution.
  -- should never happen, but it's harmless to drop them anyway.
specTickish _ other_tickish = other_tickish
834

835
specCase :: SpecEnv
836
         -> CoreExpr            -- Scrutinee, already done
837
         -> Id -> [CoreAlt]
838
839
840
         -> SpecM ( CoreExpr    -- New scrutinee
                  , Id
                  , [CoreAlt]
841
                  , UsageDetails)
842
specCase env scrut' case_bndr [(con, args, rhs)]
843
  | isDictId case_bndr           -- See Note [Floating dictionaries out of cases]
844
  , interestingDict env scrut'
845
  , not (isDeadBinder case_bndr && null sc_args')
846
  = do { (case_bndr_flt : sc_args_flt) <- mapM clone_me (case_bndr' : sc_args')
847
848
849
850
851

       ; let sc_rhss = [ Case (Var case_bndr_flt) case_bndr' (idType sc_arg')
                              [(con, args', Var sc_arg')]
                       | sc_arg' <- sc_args' ]

852
             -- Extend the substitution for RHS to map the *original* binders
853
             -- to their floated verions.  
854
             mb_sc_flts :: [Maybe DictId]
855
             mb_sc_flts = map (lookupVarEnv clone_env) args'
856
857
             clone_env  = zipVarEnv sc_args' sc_args_flt
             subst_prs  = (case_bndr, Var case_bndr_flt)
858
                        : [ (arg, Var sc_flt)
859
                          | (arg, Just sc_flt) <- args `zip` mb_sc_flts ]
860
861
862
             env_rhs' = env_rhs { se_subst = CoreSubst.extendIdSubstList (se_subst env_rhs) subst_prs
                                , se_interesting = se_interesting env_rhs `extendVarSetList`
                                                   (case_bndr_flt : sc_args_flt) }
863

864
       ; (rhs', rhs_uds)   <- specExpr env_rhs' rhs
865
866
867
868
869
870
871
872
873
874
       ; let scrut_bind    = mkDB (NonRec case_bndr_flt scrut')
             case_bndr_set = unitVarSet case_bndr_flt
             sc_binds      = [(NonRec sc_arg_flt sc_rhs, case_bndr_set)
                             | (sc_arg_flt, sc_rhs) <- sc_args_flt `zip` sc_rhss ]
             flt_binds     = scrut_bind : sc_binds
             (free_uds, dumped_dbs) = dumpUDs (case_bndr':args') rhs_uds
             all_uds = flt_binds `addDictBinds` free_uds
             alt'    = (con, args', wrapDictBindsE dumped_dbs rhs')
       ; return (Var case_bndr_flt, case_bndr', [alt'], all_uds) }
  where
875
    (env_rhs, (case_bndr':args')) = substBndrs env (case_bndr:args)
876
    sc_args' = filter is_flt_sc_arg args'
877

878
879
880
881
882
883
884
885
886
887
888
    clone_me bndr = do { uniq <- getUniqueM
                       ; return (mkUserLocal occ uniq ty loc) }
       where
         name = idName bndr
         ty   = idType bndr
         occ  = nameOccName name
         loc  = getSrcSpan name

    arg_set = mkVarSet args'
    is_flt_sc_arg var =  isId var
                      && not (isDeadBinder var)
889
                      && isDictTy var_ty
890
891
892
893
894
                      && not (tyVarsOfType var_ty `intersectsVarSet` arg_set)
       where
         var_ty = idType var


895
specCase env scrut case_bndr alts
896
897
898
  = do { (alts', uds_alts) <- mapAndCombineSM spec_alt alts
       ; return (scrut, case_bndr', alts', uds_alts) }
  where
899
    (env_alt, case_bndr') = substBndr env case_bndr
900
    spec_alt (con, args, rhs) = do
901
          (rhs', uds) <- specExpr env_rhs rhs
902
903
904
          let (free_uds, dumped_dbs) = dumpUDs (case_bndr' : args') uds
          return ((con, args', wrapDictBindsE dumped_dbs rhs'), free_uds)
        where
905
          (env_rhs, args') = substBndrs env_alt args
906
\end{code}
907

908
909
910
911
912
913
Note [Floating dictionaries out of cases]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
   g = \d. case d of { MkD sc ... -> ...(f sc)... }
Naively we can't float d2's binding out of the case expression,
because 'sc' is bound by the case, and that in turn means we can't
914
specialise f, which seems a pity.
915

916
So we invert the case, by floating out a binding
917
918
919
920
921
922
923
924
for 'sc_flt' thus:
    sc_flt = case d of { MkD sc ... -> sc }
Now we can float the call instance for 'f'.  Indeed this is just
what'll happen if 'sc' was originally bound with a let binding,
but case is more efficient, and necessary with equalities. So it's
good to work with both.

You might think that this won't make any difference, because the
925
call instance will only get nuked by the \d.  BUT if 'g' itself is
926
927
928
929
930
931
932
933
934
935
936
937
938
specialised, then transitively we should be able to specialise f.

In general, given
   case e of cb { MkD sc ... -> ...(f sc)... }
we transform to
   let cb_flt = e
       sc_flt = case cb_flt of { MkD sc ... -> sc }
   in
   case cb_flt of bg { MkD sc ... -> ....(f sc_flt)... }

The "_flt" things are the floated binds; we use the current substitution
to substitute sc -> sc_flt in the RHS

939
%************************************************************************
940
%*                                                                      *
941
                     Dealing with a binding
942
%*                                                                      *
943
944
945
%************************************************************************

\begin{code}
946
specBind :: SpecEnv                     -- Use this for RHSs
947
948
949
950
         -> CoreBind
         -> UsageDetails                -- Info on how the scope of the binding
         -> SpecM ([CoreBind],          -- New bindings
                   UsageDetails)        -- And info to pass upstream
951

952
953
-- Returned UsageDetails:
--    No calls for binders of this bind
954
955
956
specBind rhs_env (NonRec fn rhs) body_uds
  = do { (rhs', rhs_uds) <- specExpr rhs_env rhs
       ; (fn', spec_defns, body_uds1) <- specDefn rhs_env body_uds fn rhs
957

958
       ; let pairs = spec_defns ++ [(fn', rhs')]
959
960
                        -- fn' mentions the spec_defns in its rules,
                        -- so put the latter first
961

962
             combined_uds = body_uds1 `plusUDs` rhs_uds
963
964
965
966
                -- This way round a call in rhs_uds of a function f
                -- at type T will override a call of f at T in body_uds1; and
                -- that is good because it'll tend to keep "earlier" calls
                -- See Note [Specialisation of dictionary functions]
967

968
969
             (free_uds, dump_dbs, float_all) = dumpBindUDs [fn] combined_uds
                -- See Note [From non-recursive to recursive]
970
971
972
973

             final_binds | isEmptyBag dump_dbs = [NonRec b r | (b,r) <- pairs]
                         | otherwise = [Rec (flattenDictBinds dump_dbs pairs)]

974
975
976
977
         ; if float_all then
             -- Rather than discard the calls mentioning the bound variables
             -- we float this binding along with the others
              return ([], free_uds `snocDictBinds` final_binds)
978
           else
979
980
981
             -- No call in final_uds mentions bound variables,
             -- so we can just leave the binding here
              return (final_binds, free_uds) }
982
983


984
specBind rhs_env (Rec pairs) body_uds
985
986
       -- Note [Specialising a recursive group]
  = do { let (bndrs,rhss) = unzip pairs
987
       ; (rhss', rhs_uds) <- mapAndCombineSM (specExpr rhs_env) rhss
988
       ; let scope_uds = body_uds `plusUDs` rhs_uds
989
                       -- Includes binds and calls arising from rhss
990

991
       ; (bndrs1, spec_defns1, uds1) <- specDefns rhs_env scope_uds pairs
992
993
994

       ; (bndrs3, spec_defns3, uds3)
             <- if null spec_defns1  -- Common case: no specialisation
995
996
                then return (bndrs1, [], uds1)
                else do {            -- Specialisation occurred; do it again
997
                          (bndrs2, spec_defns2, uds2)
998
                              <- specDefns rhs_env uds1 (bndrs1 `zip` rhss)
999
1000
1001
1002
1003
                        ; return (bndrs2, spec_defns2 ++ spec_defns1, uds2) }

       ; let (final_uds, dumped_dbs, float_all) = dumpBindUDs bndrs uds3
             bind = Rec (flattenDictBinds dumped_dbs $
                         spec_defns3 ++ zip bndrs3 rhss')
1004

1005
       ; if float_all then
1006
              return ([], final_uds `snocDictBind` bind)
1007
           else
1008
              return ([bind], final_uds) }
1009
1010
1011


---------------------------
1012
specDefns :: SpecEnv
1013
1014
1015
1016
1017
          -> UsageDetails               -- Info on how it is used in its scope
          -> [(Id,CoreExpr)]            -- The things being bound and their un-processed RHS
          -> SpecM ([Id],               -- Original Ids with RULES added
                    [(Id,CoreExpr)],    -- Extra, specialised bindings
                    UsageDetails)       -- Stuff to fling upwards from the specialised versions
1018
1019
1020
1021
1022
1023
1024

-- Specialise a list of bindings (the contents of a Rec), but flowing usages
-- upwards binding by binding.  Example: { f = ...g ...; g = ...f .... }
-- Then if the input CallDetails has a specialised call for 'g', whose specialisation
-- in turn generates a specialised call for 'f', we catch that in this one sweep.
-- But not vice versa (it's a fixpoint problem).

1025
specDefns _env uds []
1026
  = return ([], [], uds)
1027
1028
1029
specDefns env uds ((bndr,rhs):pairs)
  = do { (bndrs1, spec_defns1, uds1) <- specDefns env uds pairs
       ; (bndr1, spec_defns2, uds2)  <- specDefn env uds1 bndr rhs
1030
       ; return (bndr1 : bndrs1, spec_defns1 ++ spec_defns2, uds2) }
1031
1032

---------------------------
1033
specDefn :: SpecEnv
1034
1035
1036
1037
1038
         -> UsageDetails                -- Info on how it is used in its scope
         -> Id -> CoreExpr              -- The thing being bound and its un-processed RHS
         -> SpecM (Id,                  -- Original Id with added RULES
                   [(Id,CoreExpr)],     -- Extra, specialised bindings
                   UsageDetails)        -- Stuff to fling upwards from the specialised versions
1039

1040
specDefn env body_uds fn rhs
1041
1042
  = do { let (body_uds_without_me, calls_for_me) = callsForMe fn body_uds
             rules_for_me = idCoreRules fn
1043
       ; (rules, spec_defns, spec_uds) <- specCalls Nothing env rules_for_me
1044
1045
1046
1047
                                                    calls_for_me fn rhs
       ; return ( fn `addIdSpecialisations` rules
                , spec_defns
                , body_uds_without_me `plusUDs` spec_uds) }
1048
1049
1050
1051
1052
1053
                -- It's important that the `plusUDs` is this way
                -- round, because body_uds_without_me may bind
                -- dictionaries that are used in calls_for_me passed
                -- to specDefn.  So the dictionary bindings in
                -- spec_uds may mention dictionaries bound in
                -- body_uds_without_me
1054
1055

---------------------------
1056
1057
1058
specCalls :: Maybe Module      -- Just this_mod  =>  specialising imported fn
                               -- Nothing        =>  specialising local fn
          -> SpecEnv
1059
1060
1061
1062
1063
1064
          -> [CoreRule]                 -- Existing RULES for the fn
          -> [CallInfo]
          -> Id -> CoreExpr
          -> SpecM ([CoreRule],         -- New RULES for the fn
                    [(Id,CoreExpr)],    -- Extra, specialised bindings
                    UsageDetails)       -- New usage details from the specialised RHSs
1065
1066

-- This function checks existing rules, and does not create
1067
-- duplicate ones. So the caller does not need to do this filtering.
1068
1069
-- See 'already_covered'

1070
specCalls mb_mod env rules_for_me calls_for_me fn rhs
1071
        -- The first case is the interesting one
1072
  |  rhs_tyvars `lengthIs`     n_tyvars -- Rhs of fn's defn has right number of big lambdas
1073
1074
  && rhs_ids    `lengthAtLeast` n_dicts -- and enough dict args
  && notNull calls_for_me               -- And there are some calls to specialise
1075
  && not (isNeverActive (idInlineActivation fn))
1076
1077
        -- Don't specialise NOINLINE things
        -- See Note [Auto-specialisation and RULES]
1078

1079
1080
1081
--   && not (certainlyWillInline (idUnfolding fn))      -- And it's not small
--      See Note [Inline specialisation] for why we do not
--      switch off specialisation for inline functions
1082

1083
1084
  = -- pprTrace "specDefn: some" (ppr fn $$ ppr calls_for_me $$ ppr rules_for_me) $
    do { stuff <- mapM spec_call calls_for_me
1085
       ; let (spec_defns, spec_uds, spec_rules) = unzip3 (catMaybes stuff)
1086
       ; return (spec_rules, spec_defns, plusUDList spec_uds) }
1087

1088
  | otherwise   -- No calls or RHS doesn't fit our preconceptions
1089
  = WARN( not (exprIsTrivial rhs) && notNull calls_for_me,
1090
          ptext (sLit "Missed specialisation opportunity for")
1091
                                 <+> ppr fn $$ _trace_doc )
1092
          -- Note [Specialisation shape]
1093
    -- pprTrace "specDefn: none" (ppr fn <+> ppr calls_for_me) $
1094
    return ([], [], emptyUDs)
1095
  where
1096
1097
1098
    _trace_doc = sep [ ppr rhs_tyvars, ppr n_tyvars
                     , ppr rhs_ids, ppr n_dicts
                     , ppr (idInlineActivation fn) ]
1099

1100
1101
1102
    fn_type            = idType fn
    fn_arity           = idArity fn
    fn_unf             = realIdUnfolding fn     -- Ignore loop-breaker-ness here
1103
    (tyvars, theta, _) = tcSplitSigmaTy fn_type
1104
1105
    n_tyvars           = length tyvars
    n_dicts            = length theta
1106
1107
1108
    inl_prag           = idInlinePragma fn
    inl_act            = inlinePragmaActivation inl_prag
    is_local           = isLocalId fn
1109

1110
1111
        -- Figure out whether the function has an INLINE pragma
        -- See Note [Inline specialisations]
1112

1113
1114
    (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs

1115
1116
    rhs_dict_ids = take n_dicts rhs_ids
    body         = mkLams (drop n_dicts rhs_ids) rhs_body
1117
                -- Glue back on the non-dict lambdas
1118

1119
1120
    already_covered :: DynFlags -> [CoreExpr] -> Bool
    already_covered dflags args      -- Note [Specialisations already covered]
1121
1122
1123
       = isJust (lookupRule dflags 
                            (CoreSubst.substInScope (se_subst env), realIdUnfolding)
                            (const True) 
1124
                            fn args rules_for_me)
1125

1126
    mk_ty_args :: [Maybe Type] -> [TyVar] -> [CoreExpr]
1127
    mk_ty_args [] poly_tvs
1128
1129
1130
1131
1132
1133
      = ASSERT( null poly_tvs ) []
    mk_ty_args (Nothing : call_ts) (poly_tv : poly_tvs)
      = Type (mkTyVarTy poly_tv) : mk_ty_args call_ts poly_tvs
    mk_ty_args (Just ty : call_ts) poly_tvs
      = Type ty : mk_ty_args call_ts poly_tvs
    mk_ty_args (Nothing : _) [] = panic "mk_ty_args"
1134