ghc/compiler/ndpFlatten/NDPCoreUtils.hs

   1 --  $Id$
   2 --
   3 --  Copyright (c) [2001..2002] Manuel M T Chakravarty & Gabriele Keller
   4 --
   5 --  Auxiliary routines for NDP-related Core transformations.
   6 --
   7 --- DESCRIPTION ---------------------------------------------------------------
   8 --
   9 --  This module exports all functions to access and alter the `Type' data
  10 --  structure from modules `Type' and `CoreExpr' from `CoreSyn'.  As it is part
  11 --  of the NDP flattening component, the functions provide access to all the
  12 --  fields that are important for the flattening and lifting transformation.
  13 --
  14 --- DOCU ----------------------------------------------------------------------
  15 --
  16 --  Language: Haskell 98
  17 --
  18 --- TODO ----------------------------------------------------------------------
  19 --
  20
  21 module NDPCoreUtils (
  22
  23   -- type inspection functions
  24   --
  25   tupleTyArgs,          -- :: Type -> [Type]
  26   funTyArgs,            -- :: Type -> (Type, Type)
  27   parrElemTy,           -- :: Type -> Type
  28
  29   -- Core generation functions
  30   --
  31   mkTuple,              -- :: [Type] -> [CoreExpr] -> CoreExpr
  32   mkInt,                -- :: CoreExpr -> CoreExpr
  33
  34   -- query functions
  35   --
  36   isDefault,            -- :: CoreAlt -> Bool
  37   isLit,                -- :: [CoreAlt] -> Bool
  38   isSimpleExpr,         -- :: CoreExpr -> Bool
  39
  40   -- re-exported functions
  41   --
  42   mkPArrTy,             -- :: Type -> Type
  43   boolTy,               -- :: Type
  44
  45   -- substitution
  46   --
  47   substIdEnv
  48 ) where
  49
  50 -- GHC
  51 import Panic      (panic)
  52 import Outputable (Outputable(ppr), pprPanic)
  53 import BasicTypes (Boxity(..))
  54 import Var        (Var)
  55 import Type       (Type, splitTyConApp_maybe, splitFunTy)
  56 import TyCon      (TyCon(..), isTupleTyCon)
  57 import PrelNames  (parrTyConName)
  58 import TysWiredIn (parrTyCon, unitDataConId, tupleCon, intDataCon, mkPArrTy,
  59                    boolTy)
  60 import CoreSyn    (CoreBndr, CoreExpr, CoreBind, CoreAlt, Expr(..), AltCon(..),
  61                    Bind(..), mkConApp)
  62 import Var        (Id)
  63 import VarEnv     (IdEnv, delVarEnv, delVarEnvList, lookupVarEnv)
  64
  65 -- friends: don't import any to avoid cyclic imports
  66 --
  67
  68
  69 -- type inspection functions
  70 -- -------------------------
  71
  72 -- determines the argument types of a tuple type (EXPORTED)
  73 --
  74 tupleTyArgs    :: Type -> [Type]
  75 tupleTyArgs ty  =
  76   case splitTyConApp_maybe ty of
  77     Just (tyCon, argTys) | isTupleTyCon tyCon -> argTys
  78     _                                         ->
  79       pprPanic "NDPCoreUtils.tupleTyArgs: wrong type: " (ppr ty)
  80
  81 -- determines the argument and result type of a function type (EXPORTED)
  82 --
  83 funTyArgs :: Type -> (Type, Type)
  84 funTyArgs  = splitFunTy
  85
  86 -- for a type of the form `[:t:]', yield `t' (EXPORTED)
  87 --
  88 -- * if the type has any other form, a fatal error occurs
  89 --
  90 parrElemTy    :: Type -> Type
  91 parrElemTy ty  =
  92   case splitTyConApp_maybe ty of
  93     Just (tyCon, [argTy]) | tyConName tyCon == parrTyConName -> argTy
  94     _                                                        ->
  95       pprPanic "NDPCoreUtils.parrElemTy: wrong type: " (ppr ty)
  96
  97
  98 -- Core generation functions
  99 -- -------------------------
 100
 101 -- make a tuple construction expression from a list of argument types and
 102 -- argument values (EXPORTED)
 103 --
 104 -- * the two lists need to be of the same length
 105 --
 106 mkTuple                                  :: [Type] -> [CoreExpr] -> CoreExpr
 107 mkTuple []  []                            = Var unitDataConId
 108 mkTuple [_] [e]                           = e
 109 mkTuple ts  es  | length ts == length es  =
 110   mkConApp (tupleCon Boxed (length es)) (map Type ts ++ es)
 111 mkTuple _   _                             =
 112   panic "NDPCoreUtils.mkTuple: mismatch between number of types and exprs!"
 113
 114 -- make a boxed integer from an unboxed one (EXPORTED)
 115 --
 116 mkInt   :: CoreExpr -> CoreExpr
 117 mkInt e  = mkConApp intDataCon [e]
 118
 119
 120 -- query functions
 121 -- ---------------
 122
 123 -- checks whether a given case alternative is a default alternative (EXPORTED)
 124 --
 125 isDefault                 :: CoreAlt -> Bool
 126 isDefault (DEFAULT, _, _)  = True
 127 isDefault _                = False
 128
 129 -- check whether a list of case alternatives in belongs to a case over a
 130 -- literal type (EXPORTED)
 131 --
 132 isLit                         :: [CoreAlt] -> Bool
 133 isLit ((DEFAULT, _, _ ):alts)  = isLit alts
 134 isLit ((LitAlt _, _, _):_   )  = True
 135 isLit _                        = False
 136
 137 -- FIXME: this function should get a more expressive name and maybe also a
 138 --        more detailed return type (depends on how the analysis goes)
 139 isSimpleExpr:: CoreExpr -> Bool
 140 isSimpleExpr _ =
 141   -- FIXME
 142   False
 143
 144
 145 --  Substitution
 146 --  -------------
 147
 148 substIdEnv:: IdEnv Id -> CoreExpr -> CoreExpr
 149 substIdEnv env e@(Lit _) = e
 150 substIdEnv env e@(Var id)  =
 151   case (lookupVarEnv env id) of
 152     Just v -> (Var v)
 153     _      -> e
 154 substIdEnv env (App e arg) =
 155   App (substIdEnv env e) (substIdEnv env arg)
 156 substIdEnv env (Lam b expr) =
 157   Lam b (substIdEnv (delVarEnv env b) expr)
 158 substIdEnv env (Let (NonRec b expr1) expr2) =
 159   Let (NonRec b (substIdEnv env expr1))
 160          (substIdEnv (delVarEnv env b) expr2)
 161 substIdEnv env (Let (Rec bnds) expr) =
 162    let
 163      newEnv  = delVarEnvList env (map fst bnds)
 164      newExpr = substIdEnv newEnv expr
 165      substBnd (b,e) = (b, substIdEnv newEnv e)
 166    in Let (Rec (map substBnd bnds)) newExpr
 167 substIdEnv env (Case expr b alts) =
 168    Case (substIdEnv newEnv expr) b (map substAlt alts)
 169    where
 170      newEnv = delVarEnv env b
 171      substAlt (c, bnds, expr) =
 172        (c, bnds, substIdEnv (delVarEnvList env bnds) expr)
 173 substIdEnv env (Note n expr) =
 174   Note n (substIdEnv env expr)
 175 substIdEnv env e@(Type t) = e