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