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
  13 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
  14 IMPORT_DELOOPER(PrelLoop)               -- here for paranoia checking
  15 IMPORT_DELOOPER(IdLoop) (SpecEnv)
  16 #else
  17 import {-# SOURCE #-} SpecEnv ( SpecEnv )
  18 #endif
  19
  20 import CoreSyn
  21 import CoreUnfold       ( UnfoldingGuidance(..), Unfolding )
  22 import Id               ( mkPrimitiveId, mkTemplateLocals )
  23 import IdInfo           -- quite a few things
  24 import StdIdInfo
  25 import Name             ( mkWiredInIdName, Name )
  26 import PrimOp           ( primOpInfo, tagOf_PrimOp, primOp_str,
  27                           PrimOpInfo(..), PrimOpResultInfo(..), PrimOp )
  28 import PrelMods         ( gHC__ )
  29 import Type             ( mkForAllTys, mkFunTy, mkFunTys, mkTyVarTy, applyTyCon )
  30 import TysWiredIn       ( boolTy )
  31 import Unique           ( mkPrimOpIdUnique )
  32 import Util             ( panic )
  33 \end{code}
  34
  35 \begin{code}
  36 primOpName       :: PrimOp -> Name
  37 primOpName op
  38   = case (primOpInfo op) of
  39       Dyadic str ty ->
  40         mk_prim_name op str [] [ty,ty] (dyadic_fun_ty ty) 2
  41
  42       Monadic str ty ->
  43         mk_prim_name op str [] [ty] (monadic_fun_ty ty) 1
  44
  45       Compare str ty ->
  46         mk_prim_name op str [] [ty,ty] (compare_fun_ty ty) 2
  47
  48       Coercing str ty1 ty2 ->
  49         mk_prim_name op str [] [ty1] (ty1 `mkFunTy` ty2) 1
  50
  51       PrimResult str tyvars arg_tys prim_tycon kind res_tys ->
  52         mk_prim_name op str
  53             tyvars
  54             arg_tys
  55             (mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon prim_tycon res_tys)))
  56             (length arg_tys) -- arity
  57
  58       AlgResult str tyvars arg_tys tycon res_tys ->
  59         mk_prim_name op str
  60             tyvars
  61             arg_tys
  62             (mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon tycon res_tys)))
  63             (length arg_tys) -- arity
  64   where
  65     mk_prim_name prim_op occ_name tyvar_tmpls arg_tys ty arity
  66       = name
  67       where
  68         key     = mkPrimOpIdUnique (IBOX(tagOf_PrimOp prim_op))
  69         name    = mkWiredInIdName key gHC__ occ_name the_id
  70         the_id  = mkPrimitiveId name ty prim_op
  71 \end{code}
  72
  73 \begin{code}
  74 dyadic_fun_ty  ty = mkFunTys [ty, ty] ty
  75 monadic_fun_ty ty = ty `mkFunTy` ty
  76 compare_fun_ty ty = mkFunTys [ty, ty] boolTy
  77 \end{code}