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