ghc/compiler/usageSP/UsageSPUtils.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1998
   3 %
   4 \section[UsageSPUtils]{UsageSP Utilities}
   5
   6 This code is (based on) PhD work of Keith Wansbrough <kw217@cl.cam.ac.uk>,
   7 September 1998 .. May 1999.
   8
   9 Keith Wansbrough 1998-09-04..1999-07-07
  10
  11 \begin{code}
  12 module UsageSPUtils ( AnnotM(AnnotM), initAnnotM,
  13                       genAnnotBinds,
  14                       MungeFlags(isSigma,isLocal,isExp,hasUsg,mfLoc),
  15
  16                       doAnnotBinds, doUnAnnotBinds,
  17                       annotTy, annotTyN, annotMany, annotManyN, unannotTy, freshannotTy,
  18
  19                       newVarUs, newVarUSMM,
  20                       UniqSMM, usToUniqSMM, uniqSMMToUs,
  21
  22                       primOpUsgTys,
  23                     ) where
  24
  25 #include "HsVersions.h"
  26
  27 import CoreSyn
  28 import CoreFVs          ( mustHaveLocalBinding )
  29 import Literal          ( Literal(..) )
  30 import Var              ( Var, varName, varType, setVarType, mkUVar )
  31 import Id               ( isExportedId )
  32 import Name             ( isLocallyDefined )
  33 import TypeRep          ( Type(..), TyNote(..) )  -- friend
  34 import Type             ( UsageAnn(..), isUsgTy, splitFunTys )
  35 import PprType          ( {- instance Outputable Type -} )
  36 import Subst            ( substTy, mkTyVarSubst )
  37 import TyCon            ( isAlgTyCon, isPrimTyCon, isSynTyCon, isFunTyCon )
  38 import VarEnv
  39 import PrimOp           ( PrimOp, primOpUsg )
  40 import Maybes           ( expectJust )
  41 import UniqSupply       ( UniqSupply, UniqSM, initUs, getUniqueUs, thenUs, returnUs )
  42 import Outputable
  43 import PprCore          ( )  -- instances only
  44 \end{code}
  45
  46 ======================================================================
  47
  48 Walking over (and altering) types
  49 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  50
  51 We often need to fiddle with (i.e., add or remove) usage annotations
  52 on a type.  We define here a general framework to do this.  Usage
  53 annotations come from any monad with a function @getAnnM@ which yields
  54 a new annotation.  We use two mutually recursive functions, one for
  55 sigma types and one for tau types.
  56
  57 \begin{code}
  58 genAnnotTy :: Monad m =>
  59               (m UsageAnn)  -- get new annotation
  60            -> Type          -- old type
  61            -> m Type        -- new type
  62
  63 genAnnotTy getAnnM ty = do { u   <- getAnnM
  64                            ; ty' <- genAnnotTyN getAnnM ty
  65                            ; return (NoteTy (UsgNote u) ty')
  66                            }
  67
  68 genAnnotTyN :: Monad m =>
  69                (m UsageAnn)
  70             -> Type
  71             -> m Type
  72
  73 genAnnotTyN getAnnM
  74   (NoteTy (UsgNote _) ty)     = panic "genAnnotTyN: unexpected UsgNote"
  75 genAnnotTyN getAnnM
  76   (NoteTy (SynNote sty) ty)   = do { sty' <- genAnnotTyN getAnnM sty
  77                                 -- is this right? shouldn't there be some
  78                                 -- correlation between sty' and ty'?
  79                                 -- But sty is a TyConApp; does this make it safer?
  80                                    ; ty'  <- genAnnotTyN getAnnM ty
  81                                    ; return (NoteTy (SynNote sty') ty')
  82                                    }
  83 genAnnotTyN getAnnM
  84   (NoteTy fvn@(FTVNote _) ty) = do { ty' <- genAnnotTyN getAnnM ty
  85                                    ; return (NoteTy fvn ty')
  86                                    }
  87
  88 genAnnotTyN getAnnM
  89   ty0@(TyVarTy _)             = do { return ty0 }
  90
  91 genAnnotTyN getAnnM
  92   (AppTy ty1 ty2)             = do { ty1' <- genAnnotTyN getAnnM ty1
  93                                    ; ty2' <- genAnnotTyN getAnnM ty2
  94                                    ; return (AppTy ty1' ty2')
  95                                    }
  96
  97 genAnnotTyN getAnnM
  98   (TyConApp tc tys)           = ASSERT( isFunTyCon tc || isAlgTyCon tc || isPrimTyCon tc || isSynTyCon tc )
  99                                 do { let gAT = if isFunTyCon tc
 100                                                then genAnnotTy  -- sigma for partial apps of (->)
 101                                                else genAnnotTyN -- tau otherwise
 102                                    ; tys' <- mapM (gAT getAnnM) tys
 103                                    ; return (TyConApp tc tys')
 104                                    }
 105
 106 genAnnotTyN getAnnM
 107   (FunTy ty1 ty2)             = do { ty1' <- genAnnotTy getAnnM ty1
 108                                    ; ty2' <- genAnnotTy getAnnM ty2
 109                                    ; return (FunTy ty1' ty2')
 110                                    }
 111
 112 genAnnotTyN getAnnM
 113   (ForAllTy v ty)             = do { ty' <- genAnnotTyN getAnnM ty
 114                                    ; return (ForAllTy v ty')
 115                                    }
 116 \end{code}
 117
 118
 119
 120 Walking over (and retyping) terms
 121 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 122
 123 We also often need to play with the types in a term.  This is slightly
 124 tricky because of redundancy: we want to change binder types, and keep
 125 the bound types matching these; then there's a special case also with
 126 non-locally-defined bound variables.  We generalise over all this
 127 here.
 128
 129 The name `annot' is a bit of a misnomer, as the code is parameterised
 130 over exactly what it does to the types (and certain terms).  Notice
 131 also that it is possible for this parameter to use
 132 monadically-threaded state: here called `flexi'.  For genuine
 133 annotation, this state will be a UniqSupply.
 134
 135 We may add annotations to the outside of a (term, not type) lambda; a
 136 function passed to @genAnnotBinds@ does this, taking the lambda and
 137 returning the annotated lambda.  It is inside the @AnnotM@ monad.
 138 This term-munging function is applied when we see either a term lambda
 139 or a usage annotation; *IMPORTANT:* it is applied *before* we recurse
 140 down into the term, and it is expected to work only at the top level.
 141 Recursion will subsequently be done by genAnnotBinds.  It may
 142 optionally remove a Note TermUsg, or optionally add one if it is not
 143 already present, but it may perform NO OTHER MODIFICATIONS to the
 144 structure of the term.
 145
 146 We do different things to types of variables bound locally and of
 147 variables bound in other modules, in certain cases: the former get
 148 uvars and the latter keep their existing annotations when we annotate,
 149 for example.  To control this, @MungeFlags@ describes what kind of a
 150 type this is that we're about to munge.
 151
 152 \begin{code}
 153 data MungeFlags = MungeFlags { isSigma :: Bool,  -- want annotated on top (sigma type)
 154                                isLocal :: Bool,  -- is locally-defined type
 155                                hasUsg  :: Bool,  -- has fixed usage info, don't touch
 156                                isExp   :: Bool,  -- is exported (and must be pessimised)
 157                                mfLoc   :: SDoc   -- location info
 158                              }
 159
 160 tauTyMF loc  = MungeFlags { isSigma = False, isLocal = True,
 161                             hasUsg = False,  isExp = False,  mfLoc = loc }
 162 sigVarTyMF v = MungeFlags { isSigma = True,  isLocal = hasLocalDef v,
 163                             hasUsg = hasUsgInfo v, isExp = isExportedId v,
 164                             mfLoc = ptext SLIT("type of binder") <+> ppr v }
 165 \end{code}
 166
 167 The helper functions @tauTyMF@ and @sigVarTyMF@ create @MungeFlags@
 168 for us.  @sigVarTyMF@ checks the variable to see how to set the flags.
 169
 170 @hasLocalDef@ tells us if the given variable has an actual local
 171 definition that we can play with.  This is not quite the same as
 172 @isLocallyDefined@, since @mayHaveNoBindingId@ things (usually) don't have
 173 a local definition - the simplifier will inline whatever their
 174 unfolding is anyway.  We treat these as if they were externally
 175 defined, since we don't have access to their definition (at least not
 176 easily).  This doesn't hurt much, since after the simplifier has run
 177 the unfolding will have been inlined and we can access the unfolding
 178 directly.
 179
 180 @hasUsgInfo@, on the other hand, says if the variable already has
 181 usage info in its type that must at all costs be preserved.  This is
 182 assumed true (exactly) of all imported ids.
 183
 184 \begin{code}
 185 hasLocalDef :: Var -> Bool
 186 hasLocalDef var = mustHaveLocalBinding var
 187
 188 hasUsgInfo :: Var -> Bool
 189 hasUsgInfo var = (not . isLocallyDefined) var
 190 \end{code}
 191
 192 Here's the walk itself.
 193
 194 \begin{code}
 195 genAnnotBinds :: (MungeFlags -> Type -> AnnotM flexi Type)
 196               -> (CoreExpr -> AnnotM flexi CoreExpr)       -- see caveats above
 197               -> [CoreBind]
 198               -> AnnotM flexi [CoreBind]
 199
 200 genAnnotBinds _ _ []     = return []
 201
 202 genAnnotBinds f g (b:bs) = do { (b',vs,vs') <- genAnnotBind f g b
 203                               ; bs' <- withAnnVars vs vs' $
 204                                          genAnnotBinds f g bs
 205                               ; return (b':bs')
 206                               }
 207
 208 genAnnotBind :: (MungeFlags -> Type -> AnnotM flexi Type)  -- type-altering function
 209              -> (CoreExpr -> AnnotM flexi CoreExpr)        -- term-altering function
 210              -> CoreBind                          -- original CoreBind
 211              -> AnnotM flexi
 212                        (CoreBind,                 -- annotated CoreBind
 213                         [Var],              -- old variables, to be mapped to...
 214                         [Var])              -- ... new variables
 215
 216 genAnnotBind f g (NonRec v1 e1) = do { v1' <- genAnnotVar f v1
 217                                      ; e1' <- genAnnotCE f g e1
 218                                      ; return (NonRec v1' e1', [v1], [v1'])
 219                                      }
 220
 221 genAnnotBind f g (Rec ves)      = do { let (vs,es) = unzip ves
 222                                      ; vs' <- mapM (genAnnotVar f) vs
 223                                      ; es' <- withAnnVars vs vs' $
 224                                                 mapM (genAnnotCE f g) es
 225                                      ; return (Rec (zip vs' es'), vs, vs')
 226                                      }
 227
 228 genAnnotCE :: (MungeFlags -> Type -> AnnotM flexi Type)  -- type-altering function
 229            -> (CoreExpr -> AnnotM flexi CoreExpr)        -- term-altering function
 230            -> CoreExpr                             -- original expression
 231            -> AnnotM flexi CoreExpr                -- yields new expression
 232
 233 genAnnotCE mungeType mungeTerm = go
 234   where go e0@(Var v) | isTyVar v    = return e0  -- arises, e.g., as tyargs of constructor
 235                                                   -- (no it doesn't: (Type (TyVar tyvar))
 236                       | otherwise    = do { mv' <- lookupAnnVar v
 237                                           ; v'  <- case mv' of
 238                                                      Just var -> return var
 239                                                      Nothing  -> fixedVar v
 240                                           ; return (Var v')
 241                                           }
 242
 243         go (Lit l)                   = -- we know it's saturated
 244                                        return (Lit l)
 245
 246         go (App e arg)               = do { e' <- go e
 247                                           ; arg' <- go arg
 248                                           ; return (App e' arg')
 249                                           }
 250
 251         go e0@(Lam v0 _)              = do { e1 <- (if isTyVar v0 then return else mungeTerm) e0
 252                                           ; let (v,e2,wrap)
 253                                                   = case e1 of  -- munge may have added note
 254                                                       Note tu@(TermUsg _) (Lam v e2)
 255                                                                -> (v,e2,Note tu)
 256                                                       Lam v e2 -> (v,e2,id)
 257                                           ; v' <- genAnnotVar mungeType v
 258                                           ; e' <- withAnnVar v v' $ go e2
 259                                           ; return (wrap (Lam v' e'))
 260                                           }
 261
 262         go (Let bind e)              = do { (bind',vs,vs') <- genAnnotBind mungeType mungeTerm bind
 263                                           ; e' <- withAnnVars vs vs' $ go e
 264                                           ; return (Let bind' e')
 265                                           }
 266
 267         go (Case e v alts)           = do { e' <- go e
 268                                           ; v' <- genAnnotVar mungeType v
 269                                           ; alts' <- withAnnVar v v' $ mapM genAnnotAlt alts
 270                                           ; return (Case e' v' alts')
 271                                           }
 272
 273         go (Note scc@(SCC _)      e) = do { e' <- go e
 274                                           ; return (Note scc e')
 275                                           }
 276         go e0@(Note (Coerce ty1 ty0)
 277                                   e) = do { ty1' <- mungeType
 278                                                       (tauTyMF (ptext SLIT("coercer of")
 279                                                                 <+> ppr e0)) ty1
 280                                           ; ty0' <- mungeType
 281                                                       (tauTyMF (ptext SLIT("coercee of")
 282                                                                 <+> ppr e0)) ty0
 283                                                  -- (Better to specify ty0'
 284                                                  --  identical to the type of e, including
 285                                                  --  annotations, right at the beginning, but
 286                                                  --  not possible at this point.)
 287                                           ; e' <- go e
 288                                           ; return (Note (Coerce ty1' ty0') e')
 289                                           }
 290         go (Note InlineCall       e) = do { e' <- go e
 291                                           ; return (Note InlineCall e')
 292                                           }
 293         go (Note InlineMe         e) = do { e' <- go e
 294                                           ; return (Note InlineMe e')
 295                                           }
 296         go e0@(Note (TermUsg _)   _) = do { e1 <- mungeTerm e0
 297                                           ; case e1 of  -- munge may have removed note
 298                                               Note tu@(TermUsg _) e2 -> do { e3 <- go e2
 299                                                                            ; return (Note tu e3)
 300                                                                            }
 301                                               e2                     -> go e2
 302                                           }
 303
 304         go e0@(Type ty)              = -- should only occur at toplevel of Arg,
 305                                        -- hence tau-type
 306                                        do { ty' <- mungeType
 307                                                      (tauTyMF (ptext SLIT("tyarg")
 308                                                                <+> ppr e0)) ty
 309                                           ; return (Type ty')
 310                                           }
 311
 312         fixedVar v = ASSERT2( not (hasLocalDef v), text "genAnnotCE: locally defined var" <+> ppr v <+> text "not in varenv" )
 313                      genAnnotVar mungeType v
 314
 315         genAnnotAlt (c,vs,e)         = do { vs' <- mapM (genAnnotVar mungeType) vs
 316                                           ; e' <- withAnnVars vs vs' $ go e
 317                                           ; return (c, vs', e')
 318                                           }
 319
 320
 321 genAnnotVar :: (MungeFlags -> Type -> AnnotM flexi Type)
 322             -> Var
 323             -> AnnotM flexi Var
 324
 325 genAnnotVar mungeType v | isTyVar v = return v
 326                         | otherwise = do { vty' <- mungeType (sigVarTyMF v) (varType v)
 327                                          ; return (setVarType v vty')
 328                                          }
 329 {- ifdef DEBUG
 330                                          ; return $
 331                                              pprTrace "genAnnotVar" (ppr (tyUsg vty') <+> ppr v) $
 332                                              (setVarType v vty')
 333    endif
 334  -}
 335 \end{code}
 336
 337 ======================================================================
 338
 339 Some specific things to do to types inside terms
 340 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 341
 342 @annotTyM@ annotates a type with fresh uvars everywhere the inference
 343 is allowed to go, and leaves alone annotations where it may not go.
 344
 345 We assume there are no annotations already.
 346
 347 \begin{code}
 348 annotTyM :: MungeFlags -> Type -> AnnotM UniqSupply Type
 349 -- general function
 350 annotTyM mf ty = uniqSMtoAnnotM . uniqSMMToUs $
 351                    case (hasUsg mf, isLocal mf, isSigma mf) of
 352                      (True ,_    ,_    ) -> ASSERT( isUsgTy ty )
 353                                             return ty
 354                      (False,True ,True ) -> if isExp mf then
 355                                               annotTyP (tag 'p') ty
 356                                             else
 357                                               annotTy (tag 's') ty
 358                      (False,True ,False) -> annotTyN (tag 't') ty
 359                      (False,False,True ) -> return $ annotMany  ty -- assume worst
 360                      (False,False,False) -> return $ annotManyN ty
 361   where tag c = Right $ "annotTyM:" ++ [c] ++ ": " ++ showSDoc (ppr ty)
 362
 363 -- specific functions for annotating tau and sigma types
 364
 365 -- ...with uvars
 366 annotTy  tag = genAnnotTy  (newVarUSMM tag)
 367 annotTyN tag = genAnnotTyN (newVarUSMM tag)
 368
 369 -- ...with uvars and pessimal Manys (for exported ids)
 370 annotTyP tag ty = do { ty' <- annotTy tag ty ; return (pessimise True ty') }
 371
 372 -- ...with Many
 373 annotMany, annotManyN :: Type -> Type
 374 #ifndef USMANY
 375 annotMany  = id
 376 annotManyN = id
 377 #else
 378 annotMany  ty = unId (genAnnotTy  (return UsMany) ty)
 379 annotManyN ty = unId (genAnnotTyN (return UsMany) ty)
 380 #endif
 381
 382 -- monad required for the above
 383 newtype Id a = Id a ; unId (Id a) = a
 384 instance Monad Id where { a >>= f  = f (unId a) ; return a = Id a }
 385
 386 -- lambda-annotating function for use along with the above
 387 annotLam e0@(Lam v e) = do { uv <- uniqSMtoAnnotM $ newVarUs (Left e0)
 388                            ; return (Note (TermUsg uv) (Lam v e))
 389                            }
 390 annotLam (Note (TermUsg _) _) = panic "annotLam: unexpected term usage annot"
 391 \end{code}
 392
 393 The above requires a `pessimising' translation.  This is applied to
 394 types of exported ids, and ensures that they have a fully general
 395 type (since we don't know how they will be used in other modules).
 396
 397 \begin{code}
 398 pessimise :: Bool -> Type -> Type
 399
 400 #ifndef USMANY
 401 pessimise  co ty0@(NoteTy  usg@(UsgNote u  ) ty)
 402   = if co
 403     then case u of UsMany  -> pty
 404                    UsVar _ -> pty  -- force to UsMany
 405                    UsOnce  -> pprPanic "pessimise:" (ppr ty0)
 406     else NoteTy usg pty
 407   where pty = pessimiseN co ty
 408
 409 pessimise  co ty0 = pessimiseN co ty0  -- assume UsMany
 410 #else
 411 pessimise  co ty0@(NoteTy  usg@(UsgNote u  ) ty)
 412   = if co
 413     then case u of UsMany  -> NoteTy usg pty
 414                    UsVar _ -> NoteTy (UsgNote UsMany) pty
 415                    UsOnce  -> pprPanic "pessimise:" (ppr ty0)
 416     else NoteTy usg pty
 417   where pty = pessimiseN co ty
 418
 419 pessimise  co ty0                                = pprPanic "pessimise: missing usage note:" $
 420                                                             ppr ty0
 421 #endif
 422
 423 pessimiseN co ty0@(NoteTy  usg@(UsgNote _  ) ty) = pprPanic "pessimiseN: unexpected usage note:" $
 424                                                             ppr ty0
 425 pessimiseN co     (NoteTy      (SynNote sty) ty) = NoteTy (SynNote (pessimiseN co sty))
 426                                                                    (pessimiseN co ty )
 427 pessimiseN co     (NoteTy note@(FTVNote _  ) ty) = NoteTy note (pessimiseN co ty)
 428 pessimiseN co ty0@(TyVarTy _)                    = ty0
 429 pessimiseN co ty0@(AppTy _ _)                    = ty0
 430 pessimiseN co ty0@(TyConApp tc tys)              = ASSERT( not ((isFunTyCon tc) && (length tys > 1)) )
 431                                                    ty0
 432 pessimiseN co     (FunTy ty1 ty2)                = FunTy (pessimise (not co) ty1)
 433                                                          (pessimise      co  ty2)
 434 pessimiseN co     (ForAllTy tyv ty)              = ForAllTy tyv (pessimiseN co ty)
 435 \end{code}
 436
 437
 438 @unAnnotTyM@ strips annotations (that the inference is allowed to
 439 touch) from a term, and `fixes' those it isn't permitted to touch (by
 440 putting @Many@ annotations where they are missing, but leaving
 441 existing annotations in the type).
 442
 443 @unTermUsg@ removes from a term any term usage annotations it finds.
 444
 445 \begin{code}
 446 unAnnotTyM :: MungeFlags -> Type -> AnnotM a Type
 447
 448 unAnnotTyM mf ty = if hasUsg mf then
 449                      ASSERT( isSigma mf )
 450                      return (fixAnnotTy ty)
 451                    else return (unannotTy ty)
 452
 453
 454 unTermUsg :: CoreExpr -> AnnotM a CoreExpr
 455 -- strip all term annotations
 456 unTermUsg e@(Lam _ _)          = return e
 457 unTermUsg (Note (TermUsg _) e) = return e
 458 unTermUsg _                    = panic "unTermUsg"
 459
 460 unannotTy :: Type -> Type
 461 -- strip all annotations
 462 unannotTy    (NoteTy     (UsgForAll uv) ty) = unannotTy ty
 463 unannotTy    (NoteTy      (UsgNote _  ) ty) = unannotTy ty
 464 unannotTy    (NoteTy      (SynNote sty) ty) = NoteTy (SynNote (unannotTy sty)) (unannotTy ty)
 465 unannotTy    (NoteTy note@(FTVNote _  ) ty) = NoteTy note (unannotTy ty)
 466 -- IP notes need to be preserved
 467 unannotTy ty@(NoteTy         (IPNote _) _)  = ty
 468 unannotTy ty@(TyVarTy _)                    = ty
 469 unannotTy    (AppTy ty1 ty2)                = AppTy (unannotTy ty1) (unannotTy ty2)
 470 unannotTy    (TyConApp tc tys)              = TyConApp tc (map unannotTy tys)
 471 unannotTy    (FunTy ty1 ty2)                = FunTy (unannotTy ty1) (unannotTy ty2)
 472 unannotTy    (ForAllTy tyv ty)              = ForAllTy tyv (unannotTy ty)
 473
 474
 475 fixAnnotTy :: Type -> Type
 476 -- put Manys where they are missing
 477 #ifndef USMANY
 478 fixAnnotTy = id
 479 #else
 480 fixAnnotTy     (NoteTy note@(UsgForAll uv) ty) = NoteTy note (fixAnnotTy  ty)
 481 fixAnnotTy      (NoteTy note@(UsgNote _  ) ty) = NoteTy note (fixAnnotTyN ty)
 482 fixAnnotTy  ty0                                = NoteTy (UsgNote UsMany) (fixAnnotTyN ty0)
 483
 484 fixAnnotTyN ty0@(NoteTy note@(UsgNote _  ) ty) = pprPanic "fixAnnotTyN: unexpected usage note:" $
 485                                                           ppr ty0
 486 fixAnnotTyN     (NoteTy      (SynNote sty) ty) = NoteTy (SynNote (fixAnnotTyN sty))
 487                                                                  (fixAnnotTyN ty )
 488 fixAnnotTyN     (NoteTy note@(FTVNote _  ) ty) = NoteTy note (fixAnnotTyN ty)
 489 fixAnnotTyN ty0@(TyVarTy _)                    = ty0
 490 fixAnnotTyN     (AppTy ty1 ty2)                = AppTy (fixAnnotTyN ty1) (fixAnnotTyN ty2)
 491 fixAnnotTyN     (TyConApp tc tys)              = ASSERT( isFunTyCon tc || isAlgTyCon tc || isPrimTyCon tc || isSynTyCon tc )
 492                                                  TyConApp tc (map (if isFunTyCon tc then
 493                                                                      fixAnnotTy
 494                                                                    else
 495                                                                      fixAnnotTyN) tys)
 496 fixAnnotTyN     (FunTy ty1 ty2)                = FunTy (fixAnnotTy ty1) (fixAnnotTy ty2)
 497 fixAnnotTyN     (ForAllTy tyv ty)              = ForAllTy tyv (fixAnnotTyN ty)
 498 #endif
 499 \end{code}
 500
 501 The composition (reannotating a type with fresh uvars but the same
 502 structure) is useful elsewhere:
 503
 504 \begin{code}
 505 freshannotTy :: Type -> UniqSMM Type
 506 freshannotTy = annotTy (Right "freshannotTy") . unannotTy
 507 \end{code}
 508
 509
 510 Wrappers apply these functions to sets of bindings.
 511
 512 \begin{code}
 513 doAnnotBinds :: UniqSupply
 514              -> [CoreBind]
 515              -> ([CoreBind],UniqSupply)
 516
 517 doAnnotBinds us binds = initAnnotM us (genAnnotBinds annotTyM annotLam binds)
 518
 519
 520 doUnAnnotBinds :: [CoreBind]
 521                -> [CoreBind]
 522
 523 doUnAnnotBinds binds = fst $ initAnnotM () $
 524                          genAnnotBinds unAnnotTyM unTermUsg binds
 525 \end{code}
 526
 527 ======================================================================
 528
 529 Monadic machinery
 530 ~~~~~~~~~~~~~~~~~
 531
 532 The @UniqSM@ type is not an instance of @Monad@, and cannot be made so
 533 since it is merely a synonym rather than a newtype.  Here we define
 534 @UniqSMM@, which *is* an instance of @Monad@.
 535
 536 \begin{code}
 537 newtype UniqSMM a = UsToUniqSMM (UniqSM a)
 538 uniqSMMToUs (UsToUniqSMM us) = us
 539 usToUniqSMM = UsToUniqSMM
 540
 541 instance Monad UniqSMM where
 542   m >>= f  = UsToUniqSMM $ uniqSMMToUs m `thenUs` \ a ->
 543                            uniqSMMToUs (f a)
 544   return   = UsToUniqSMM . returnUs
 545 \end{code}
 546
 547
 548 For annotation, the monad @AnnotM@, we need to carry around our
 549 variable mapping, along with some general state.
 550
 551 \begin{code}
 552 newtype AnnotM flexi a = AnnotM (   flexi                     -- UniqSupply etc
 553                                   -> VarEnv Var         -- unannotated to annotated variables
 554                                   -> (a,flexi,VarEnv Var))
 555 unAnnotM (AnnotM f) = f
 556
 557 instance Monad (AnnotM flexi) where
 558   a >>= f  = AnnotM (\ us ve -> let (r,us',ve') = unAnnotM a us ve
 559                                 in  unAnnotM (f r) us' ve')
 560   return a = AnnotM (\ us ve -> (a,us,ve))
 561
 562 initAnnotM :: fl -> AnnotM fl a -> (a,fl)
 563 initAnnotM fl m = case (unAnnotM m) fl emptyVarEnv of { (r,fl',_) -> (r,fl') }
 564
 565 withAnnVar :: Var -> Var -> AnnotM fl a -> AnnotM fl a
 566 withAnnVar v v' m = AnnotM (\ us ve -> let ve'          = extendVarEnv ve v v'
 567                                            (r,us',_)    = (unAnnotM m) us ve'
 568                                        in  (r,us',ve))
 569
 570 withAnnVars :: [Var] -> [Var] -> AnnotM fl a -> AnnotM fl a
 571 withAnnVars vs vs' m = AnnotM (\ us ve -> let ve'          = plusVarEnv ve (zipVarEnv vs vs')
 572                                               (r,us',_)    = (unAnnotM m) us ve'
 573                                           in  (r,us',ve))
 574
 575 lookupAnnVar :: Var -> AnnotM fl (Maybe Var)
 576 lookupAnnVar var = AnnotM (\ us ve -> (lookupVarEnv ve var,
 577                                        us,
 578                                        ve))
 579 \end{code}
 580
 581 A useful helper allows us to turn a computation in the unique supply
 582 monad into one in the annotation monad parameterised by a unique
 583 supply.
 584
 585 \begin{code}
 586 uniqSMtoAnnotM :: UniqSM a -> AnnotM UniqSupply a
 587
 588 uniqSMtoAnnotM m = AnnotM (\ us ve -> let (r,us') = initUs us m
 589                                       in  (r,us',ve))
 590 \end{code}
 591
 592 @newVarUs@ and @newVarUSMM@ generate a new usage variable.  They take
 593 an argument which is used for debugging only, describing what the
 594 variable is to annotate.
 595
 596 \begin{code}
 597 newVarUs :: (Either CoreExpr String) -> UniqSM UsageAnn
 598 -- the first arg is for debugging use only
 599 newVarUs e = getUniqueUs `thenUs` \ u ->
 600              let uv = mkUVar u in
 601              returnUs (UsVar uv)
 602 {- #ifdef DEBUG
 603              let src = case e of
 604                          Left (Lit _) -> "literal"
 605                          Left (Lam v e)           -> "lambda: " ++ showSDoc (ppr v)
 606                          Left _                   -> "unknown"
 607                          Right s                  -> s
 608              in pprTrace "newVarUs:" (ppr uv <+> text src) $
 609    #endif
 610  -}
 611
 612 newVarUSMM :: (Either CoreExpr String) -> UniqSMM UsageAnn
 613 newVarUSMM = usToUniqSMM . newVarUs
 614 \end{code}
 615
 616 ======================================================================
 617
 618 PrimOps and usage information.
 619
 620 Analagously to @DataCon.dataConArgTys@, we determine the argtys and
 621 result ty of a primop, *after* substition (which may reveal more args,
 622 notably for @CCall@s).
 623
 624 \begin{code}
 625 primOpUsgTys :: PrimOp         -- this primop
 626              -> [Type]         -- instantiated at these (tau) types
 627              -> ([Type],Type)  -- requires args of these (sigma) types,
 628                                --  and returns this (sigma) type
 629
 630 primOpUsgTys p tys = let (tyvs,ty0us,rtyu) = primOpUsg p
 631                          s                 = mkTyVarSubst tyvs tys
 632                          (ty1us,rty1u)     = splitFunTys (substTy s rtyu)
 633                                              -- substitution may reveal more args
 634                      in  ((map (substTy s) ty0us) ++ ty1us,
 635                           rty1u)
 636 \end{code}
 637
 638 ======================================================================
 639
 640 EOF