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 module IdUtils ( primOpName ) where
   8
   9 #include "HsVersions.h"
  10
  11 import CoreSyn
  12 import CoreUnfold       ( Unfolding )
  13 import Id               ( mkPrimitiveId )
  14 import IdInfo           -- quite a few things
  15 import StdIdInfo
  16 import Name             ( mkWiredInIdName, Name )
  17 import PrimOp           ( primOpInfo, tagOf_PrimOp, PrimOpInfo(..), PrimOp )
  18 import PrelMods         ( pREL_GHC )
  19 import Type             ( mkForAllTys, mkFunTy, mkFunTys, mkTyConApp )
  20 import TysWiredIn       ( boolTy )
  21 import Unique           ( mkPrimOpIdUnique )
  22 import Util             ( panic )
  23 \end{code}
  24
  25 \begin{code}
  26 primOpName       :: PrimOp -> Name
  27 primOpName op
  28   = case (primOpInfo op) of
  29       Dyadic str ty ->
  30         mk_prim_name op str [] [ty,ty] (dyadic_fun_ty ty) 2
  31
  32       Monadic str ty ->
  33         mk_prim_name op str [] [ty] (monadic_fun_ty ty) 1
  34
  35       Compare str ty ->
  36         mk_prim_name op str [] [ty,ty] (compare_fun_ty ty) 2
  37
  38       Coercing str ty1 ty2 ->
  39         mk_prim_name op str [] [ty1] (ty1 `mkFunTy` ty2) 1
  40
  41       PrimResult str tyvars arg_tys prim_tycon kind res_tys ->
  42         mk_prim_name op str
  43             tyvars
  44             arg_tys
  45             (mkForAllTys tyvars (mkFunTys arg_tys (mkTyConApp prim_tycon res_tys)))
  46             (length arg_tys) -- arity
  47
  48       AlgResult str tyvars arg_tys tycon res_tys ->
  49         mk_prim_name op str
  50             tyvars
  51             arg_tys
  52             (mkForAllTys tyvars (mkFunTys arg_tys (mkTyConApp tycon res_tys)))
  53             (length arg_tys) -- arity
  54   where
  55     mk_prim_name prim_op occ_name tyvar_tmpls arg_tys ty arity
  56       = name
  57       where
  58         key     = mkPrimOpIdUnique (IBOX(tagOf_PrimOp prim_op))
  59         name    = mkWiredInIdName key pREL_GHC occ_name the_id
  60         the_id  = mkPrimitiveId name ty prim_op
  61 \end{code}
  62
  63 \begin{code}
  64 dyadic_fun_ty  ty = mkFunTys [ty, ty] ty
  65 monadic_fun_ty ty = ty `mkFunTy` ty
  66 compare_fun_ty ty = mkFunTys [ty, ty] boolTy
  67 \end{code}