ghc/compiler/basicTypes/IdUtils.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[IdUtils]{Constructing PrimOp Ids}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module IdUtils ( primOpName ) where
  10
  11 IMP_Ubiq()
  12 IMPORT_DELOOPER(PrelLoop)               -- here for paranoia checking
  13 IMPORT_DELOOPER(IdLoop) (SpecEnv)
  14
  15 import CoreSyn
  16 import CoreUnfold       ( UnfoldingGuidance(..), Unfolding, mkUnfolding )
  17 import Id               ( mkPrimitiveId, mkTemplateLocals )
  18 import IdInfo           -- quite a few things
  19 import StdIdInfo
  20 import Name             ( mkWiredInIdName )
  21 import PrimOp           ( primOpInfo, tagOf_PrimOp, primOp_str,
  22                           PrimOpInfo(..), PrimOpResultInfo(..) )
  23 import PrelMods         ( gHC__ )
  24 import Type             ( mkForAllTys, mkFunTy, mkFunTys, mkTyVarTy, applyTyCon )
  25 import TysWiredIn       ( boolTy )
  26 import Unique           ( mkPrimOpIdUnique )
  27 import Util             ( panic )
  28 \end{code}
  29
  30 \begin{code}
  31 primOpName       :: PrimOp -> Name
  32 primOpName op
  33   = case (primOpInfo op) of
  34       Dyadic str ty ->
  35         mk_prim_name op str [] [ty,ty] (dyadic_fun_ty ty) 2
  36
  37       Monadic str ty ->
  38         mk_prim_name op str [] [ty] (monadic_fun_ty ty) 1
  39
  40       Compare str ty ->
  41         mk_prim_name op str [] [ty,ty] (compare_fun_ty ty) 2
  42
  43       Coercing str ty1 ty2 ->
  44         mk_prim_name op str [] [ty1] (ty1 `mkFunTy` ty2) 1
  45
  46       PrimResult str tyvars arg_tys prim_tycon kind res_tys ->
  47         mk_prim_name op str
  48             tyvars
  49             arg_tys
  50             (mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon prim_tycon res_tys)))
  51             (length arg_tys) -- arity
  52
  53       AlgResult str tyvars arg_tys tycon res_tys ->
  54         mk_prim_name op str
  55             tyvars
  56             arg_tys
  57             (mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon tycon res_tys)))
  58             (length arg_tys) -- arity
  59   where
  60     mk_prim_name prim_op occ_name tyvar_tmpls arg_tys ty arity
  61       = name
  62       where
  63         key     = mkPrimOpIdUnique (IBOX(tagOf_PrimOp prim_op))
  64         name    = mkWiredInIdName key gHC__ occ_name the_id
  65         the_id  = mkPrimitiveId name ty prim_op
  66 \end{code}
  67
  68 \begin{code}
  69 dyadic_fun_ty  ty = mkFunTys [ty, ty] ty
  70 monadic_fun_ty ty = ty `mkFunTy` ty
  71 compare_fun_ty ty = mkFunTys [ty, ty] boolTy
  72 \end{code}