2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[IdUtils]{Constructing PrimOp Ids}
7 #include "HsVersions.h"
9 module IdUtils ( primOpName ) where
13 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
14 IMPORT_DELOOPER(PrelLoop) -- here for paranoia checking
15 IMPORT_DELOOPER(IdLoop) (SpecEnv)
17 import {-# SOURCE #-} SpecEnv ( SpecEnv )
21 import CoreUnfold ( UnfoldingGuidance(..), Unfolding )
22 import Id ( mkPrimitiveId, mkTemplateLocals )
23 import IdInfo -- quite a few things
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 )
36 primOpName :: PrimOp -> Name
38 = case (primOpInfo op) of
40 mk_prim_name op str [] [ty,ty] (dyadic_fun_ty ty) 2
43 mk_prim_name op str [] [ty] (monadic_fun_ty ty) 1
46 mk_prim_name op str [] [ty,ty] (compare_fun_ty ty) 2
48 Coercing str ty1 ty2 ->
49 mk_prim_name op str [] [ty1] (ty1 `mkFunTy` ty2) 1
51 PrimResult str tyvars arg_tys prim_tycon kind res_tys ->
55 (mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon prim_tycon res_tys)))
56 (length arg_tys) -- arity
58 AlgResult str tyvars arg_tys tycon res_tys ->
62 (mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon tycon res_tys)))
63 (length arg_tys) -- arity
65 mk_prim_name prim_op occ_name tyvar_tmpls arg_tys ty arity
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
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