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 {-# OPTIONS_GHC -w #-}
  22 -- The above warning supression flag is a temporary kludge.
  23 -- While working on this module you are encouraged to remove it and fix
  24 -- any warnings in the module. See
  25 --     http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
  26 -- for details
  27
  28 module NDPCoreUtils (
  29
  30   -- type inspection functions
  31   --
  32   tupleTyArgs,          -- :: Type -> [Type]
  33   funTyArgs,            -- :: Type -> (Type, Type)
  34   parrElemTy,           -- :: Type -> Type
  35
  36   -- Core generation functions
  37   --
  38   mkTuple,              -- :: [Type] -> [CoreExpr] -> CoreExpr
  39   mkInt,                -- :: CoreExpr -> CoreExpr
  40
  41   -- query functions
  42   --
  43   isDefault,            -- :: CoreAlt -> Bool
  44   isLit,                -- :: [CoreAlt] -> Bool
  45   isSimpleExpr,         -- :: CoreExpr -> Bool
  46
  47   -- re-exported functions
  48   --
  49   mkPArrTy,             -- :: Type -> Type
  50   boolTy,               -- :: Type
  51
  52   -- substitution
  53   --
  54   substIdEnv
  55 ) where
  56
  57 -- GHC
  58 import Panic      (panic)
  59 import Outputable (Outputable(ppr), pprPanic)
  60 import BasicTypes (Boxity(..))
  61 import Type       (Type, splitTyConApp_maybe, splitFunTy)
  62 import TyCon      (isTupleTyCon)
  63 import TysWiredIn (parrTyCon, unitDataConId, tupleCon, intDataCon, mkPArrTy,
  64                    boolTy)
  65 import CoreSyn    (CoreExpr, CoreAlt, Expr(..), AltCon(..),
  66                    Bind(..), mkConApp)
  67 import PprCore    ( {- instances -} )
  68 import Var        (Id)
  69 import VarEnv     (IdEnv, delVarEnv, delVarEnvList, lookupVarEnv)
  70
  71 -- friends: don't import any to avoid cyclic imports
  72 --
  73
  74
  75 -- type inspection functions
  76 -- -------------------------
  77
  78 -- determines the argument types of a tuple type (EXPORTED)
  79 --
  80 tupleTyArgs    :: Type -> [Type]
  81 tupleTyArgs ty  =
  82   case splitTyConApp_maybe ty of
  83     Just (tyCon, argTys) | isTupleTyCon tyCon -> argTys
  84     _                                         ->
  85       pprPanic "NDPCoreUtils.tupleTyArgs: wrong type: " (ppr ty)
  86
  87 -- determines the argument and result type of a function type (EXPORTED)
  88 --
  89 funTyArgs :: Type -> (Type, Type)
  90 funTyArgs  = splitFunTy
  91
  92 -- for a type of the form `[:t:]', yield `t' (EXPORTED)
  93 --
  94 --  * if the type has any other form, a fatal error occurs
  95 --
  96 parrElemTy    :: Type -> Type
  97 parrElemTy ty  =
  98   case splitTyConApp_maybe ty of
  99     Just (tyCon, [argTy]) | tyCon == parrTyCon -> argTy
 100     _                                                        ->
 101       pprPanic "NDPCoreUtils.parrElemTy: wrong type: " (ppr ty)
 102
 103
 104 -- Core generation functions
 105 -- -------------------------
 106
 107 -- make a tuple construction expression from a list of argument types and
 108 -- argument values (EXPORTED)
 109 --
 110 --  * the two lists need to be of the same length
 111 --
 112 mkTuple                                  :: [Type] -> [CoreExpr] -> CoreExpr
 113 mkTuple []  []                            = Var unitDataConId
 114 mkTuple [_] [e]                           = e
 115 mkTuple ts  es  | length ts == length es  =
 116   mkConApp (tupleCon Boxed (length es)) (map Type ts ++ es)
 117 mkTuple _   _                             =
 118   panic "NDPCoreUtils.mkTuple: mismatch between number of types and exprs!"
 119
 120 -- make a boxed integer from an unboxed one (EXPORTED)
 121 --
 122 mkInt   :: CoreExpr -> CoreExpr
 123 mkInt e  = mkConApp intDataCon [e]
 124
 125
 126 -- query functions
 127 -- ---------------
 128
 129 -- checks whether a given case alternative is a default alternative (EXPORTED)
 130 --
 131 isDefault                 :: CoreAlt -> Bool
 132 isDefault (DEFAULT, _, _)  = True
 133 isDefault _                = False
 134
 135 -- check whether a list of case alternatives in belongs to a case over a
 136 -- literal type (EXPORTED)
 137 --
 138 isLit                         :: [CoreAlt] -> Bool
 139 isLit ((DEFAULT, _, _ ):alts)  = isLit alts
 140 isLit ((LitAlt _, _, _):_   )  = True
 141 isLit _                        = False
 142
 143 -- FIXME: this function should get a more expressive name and maybe also a
 144 --        more detailed return type (depends on how the analysis goes)
 145 isSimpleExpr:: CoreExpr -> Bool
 146 isSimpleExpr _ =
 147   -- FIXME
 148   False
 149
 150
 151 --  Substitution
 152 --  -------------
 153
 154 substIdEnv:: IdEnv Id -> CoreExpr -> CoreExpr
 155 substIdEnv env e@(Lit _) = e
 156 substIdEnv env e@(Var id)  =
 157   case (lookupVarEnv env id) of
 158     Just v -> (Var v)
 159     _      -> e
 160 substIdEnv env (App e arg) =
 161   App (substIdEnv env e) (substIdEnv env arg)
 162 substIdEnv env (Lam b expr) =
 163   Lam b (substIdEnv (delVarEnv env b) expr)
 164 substIdEnv env (Let (NonRec b expr1) expr2) =
 165   Let (NonRec b (substIdEnv env expr1))
 166          (substIdEnv (delVarEnv env b) expr2)
 167 substIdEnv env (Let (Rec bnds) expr) =
 168    let
 169      newEnv  = delVarEnvList env (map fst bnds)
 170      newExpr = substIdEnv newEnv expr
 171      substBnd (b,e) = (b, substIdEnv newEnv e)
 172    in Let (Rec (map substBnd bnds)) newExpr
 173 substIdEnv env (Case expr b ty alts) =
 174    Case (substIdEnv newEnv expr) b ty (map substAlt alts)
 175    where
 176      newEnv = delVarEnv env b
 177      substAlt (c, bnds, expr) =
 178        (c, bnds, substIdEnv (delVarEnvList env bnds) expr)
 179 substIdEnv env (Note n expr) =
 180   Note n (substIdEnv env expr)
 181 substIdEnv env (Cast e co) = Cast (substIdEnv env e) co
 182 substIdEnv env e@(Type t) = e