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