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 Type       (Type, splitTyConApp_maybe, splitFunTy)
  55 import TyCon      (isTupleTyCon)
  56 import TysWiredIn (parrTyCon, unitDataConId, tupleCon, intDataCon, mkPArrTy,
  57                    boolTy)
  58 import CoreSyn    (CoreExpr, CoreAlt, Expr(..), AltCon(..),
  59                    Bind(..), mkConApp)
  60 import PprCore    ( {- instances -} )
  61 import Var        (Id)
  62 import VarEnv     (IdEnv, delVarEnv, delVarEnvList, lookupVarEnv)
  63
  64 -- friends: don't import any to avoid cyclic imports
  65 --
  66
  67
  68 -- type inspection functions
  69 -- -------------------------
  70
  71 -- determines the argument types of a tuple type (EXPORTED)
  72 --
  73 tupleTyArgs    :: Type -> [Type]
  74 tupleTyArgs ty  =
  75   case splitTyConApp_maybe ty of
  76     Just (tyCon, argTys) | isTupleTyCon tyCon -> argTys
  77     _                                         ->
  78       pprPanic "NDPCoreUtils.tupleTyArgs: wrong type: " (ppr ty)
  79
  80 -- determines the argument and result type of a function type (EXPORTED)
  81 --
  82 funTyArgs :: Type -> (Type, Type)
  83 funTyArgs  = splitFunTy
  84
  85 -- for a type of the form `[:t:]', yield `t' (EXPORTED)
  86 --
  87 --  * if the type has any other form, a fatal error occurs
  88 --
  89 parrElemTy    :: Type -> Type
  90 parrElemTy ty  =
  91   case splitTyConApp_maybe ty of
  92     Just (tyCon, [argTy]) | tyCon == parrTyCon -> argTy
  93     _                                                        ->
  94       pprPanic "NDPCoreUtils.parrElemTy: wrong type: " (ppr ty)
  95
  96
  97 -- Core generation functions
  98 -- -------------------------
  99
 100 -- make a tuple construction expression from a list of argument types and
 101 -- argument values (EXPORTED)
 102 --
 103 --  * the two lists need to be of the same length
 104 --
 105 mkTuple                                  :: [Type] -> [CoreExpr] -> CoreExpr
 106 mkTuple []  []                            = Var unitDataConId
 107 mkTuple [_] [e]                           = e
 108 mkTuple ts  es  | length ts == length es  =
 109   mkConApp (tupleCon Boxed (length es)) (map Type ts ++ es)
 110 mkTuple _   _                             =
 111   panic "NDPCoreUtils.mkTuple: mismatch between number of types and exprs!"
 112
 113 -- make a boxed integer from an unboxed one (EXPORTED)
 114 --
 115 mkInt   :: CoreExpr -> CoreExpr
 116 mkInt e  = mkConApp intDataCon [e]
 117
 118
 119 -- query functions
 120 -- ---------------
 121
 122 -- checks whether a given case alternative is a default alternative (EXPORTED)
 123 --
 124 isDefault                 :: CoreAlt -> Bool
 125 isDefault (DEFAULT, _, _)  = True
 126 isDefault _                = False
 127
 128 -- check whether a list of case alternatives in belongs to a case over a
 129 -- literal type (EXPORTED)
 130 --
 131 isLit                         :: [CoreAlt] -> Bool
 132 isLit ((DEFAULT, _, _ ):alts)  = isLit alts
 133 isLit ((LitAlt _, _, _):_   )  = True
 134 isLit _                        = False
 135
 136 -- FIXME: this function should get a more expressive name and maybe also a
 137 --        more detailed return type (depends on how the analysis goes)
 138 isSimpleExpr:: CoreExpr -> Bool
 139 isSimpleExpr _ =
 140   -- FIXME
 141   False
 142
 143
 144 --  Substitution
 145 --  -------------
 146
 147 substIdEnv:: IdEnv Id -> CoreExpr -> CoreExpr
 148 substIdEnv env e@(Lit _) = e
 149 substIdEnv env e@(Var id)  =
 150   case (lookupVarEnv env id) of
 151     Just v -> (Var v)
 152     _      -> e
 153 substIdEnv env (App e arg) =
 154   App (substIdEnv env e) (substIdEnv env arg)
 155 substIdEnv env (Lam b expr) =
 156   Lam b (substIdEnv (delVarEnv env b) expr)
 157 substIdEnv env (Let (NonRec b expr1) expr2) =
 158   Let (NonRec b (substIdEnv env expr1))
 159          (substIdEnv (delVarEnv env b) expr2)
 160 substIdEnv env (Let (Rec bnds) expr) =
 161    let
 162      newEnv  = delVarEnvList env (map fst bnds)
 163      newExpr = substIdEnv newEnv expr
 164      substBnd (b,e) = (b, substIdEnv newEnv e)
 165    in Let (Rec (map substBnd bnds)) newExpr
 166 substIdEnv env (Case expr b ty alts) =
 167    Case (substIdEnv newEnv expr) b ty (map substAlt alts)
 168    where
 169      newEnv = delVarEnv env b
 170      substAlt (c, bnds, expr) =
 171        (c, bnds, substIdEnv (delVarEnvList env bnds) expr)
 172 substIdEnv env (Note n expr) =
 173   Note n (substIdEnv env expr)
 174 substIdEnv env e@(Type t) = e