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 ( primOpNameInfo, primOpId ) where
  10
  11 IMP_Ubiq()
  12 IMPORT_DELOOPER(PrelLoop)               -- here for paranoia checking
  13
  14 import CoreSyn
  15 import CoreUnfold       ( UnfoldingGuidance(..) )
  16 import Id               ( mkPreludeId, mkTemplateLocals )
  17 import IdInfo           -- quite a few things
  18 import Name             ( mkBuiltinName )
  19 import PrelMods         ( pRELUDE_BUILTIN )
  20 import PrimOp           ( primOpInfo, tagOf_PrimOp, primOp_str,
  21                           PrimOpInfo(..), PrimOpResultInfo(..) )
  22 import RnHsSyn          ( RnName(..) )
  23 import Type             ( mkForAllTys, mkFunTys, mkTyVarTy, applyTyCon )
  24 import TysWiredIn       ( boolTy )
  25 import Unique           ( mkPrimOpIdUnique )
  26 import Util             ( panic )
  27 \end{code}
  28
  29 \begin{code}
  30 primOpNameInfo :: PrimOp -> (FAST_STRING, RnName)
  31 primOpId       :: PrimOp -> Id
  32
  33 primOpNameInfo op = (primOp_str  op, WiredInId (primOpId op))
  34
  35 primOpId op
  36   = case (primOpInfo op) of
  37       Dyadic str ty ->
  38         mk_prim_Id op pRELUDE_BUILTIN str [] [ty,ty] (dyadic_fun_ty ty) 2
  39
  40       Monadic str ty ->
  41         mk_prim_Id op pRELUDE_BUILTIN str [] [ty] (monadic_fun_ty ty) 1
  42
  43       Compare str ty ->
  44         mk_prim_Id op pRELUDE_BUILTIN str [] [ty,ty] (compare_fun_ty ty) 2
  45
  46       Coercing str ty1 ty2 ->
  47         mk_prim_Id op pRELUDE_BUILTIN str [] [ty1] (mkFunTys [ty1] ty2) 1
  48
  49       PrimResult str tyvars arg_tys prim_tycon kind res_tys ->
  50         mk_prim_Id op pRELUDE_BUILTIN str
  51             tyvars
  52             arg_tys
  53             (mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon prim_tycon res_tys)))
  54             (length arg_tys) -- arity
  55
  56       AlgResult str tyvars arg_tys tycon res_tys ->
  57         mk_prim_Id op pRELUDE_BUILTIN str
  58             tyvars
  59             arg_tys
  60             (mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon tycon res_tys)))
  61             (length arg_tys) -- arity
  62   where
  63     mk_prim_Id prim_op mod name tyvar_tmpls arg_tys ty arity
  64       = mkPreludeId (mkBuiltinName key mod name) ty
  65            (noIdInfo `addInfo` (mkArityInfo arity)
  66                   `addInfo_UF` (mkUnfolding EssentialUnfolding
  67                                  (mk_prim_unfold prim_op tyvar_tmpls arg_tys)))
  68       where
  69         key = mkPrimOpIdUnique (IBOX(tagOf_PrimOp prim_op))
  70 \end{code}
  71
  72
  73 \begin{code}
  74 dyadic_fun_ty  ty = mkFunTys [ty, ty] ty
  75 monadic_fun_ty ty = mkFunTys [ty] ty
  76 compare_fun_ty ty = mkFunTys [ty, ty] boolTy
  77 \end{code}
  78
  79 The functions to make common unfoldings are tedious.
  80
  81 \begin{code}
  82 mk_prim_unfold :: PrimOp -> [TyVar] -> [Type] -> CoreExpr{-template-}
  83
  84 mk_prim_unfold prim_op tyvars arg_tys
  85   = let
  86         vars = mkTemplateLocals arg_tys
  87     in
  88     mkLam tyvars vars $
  89     Prim prim_op
  90         ([TyArg (mkTyVarTy tv) | tv <- tyvars] ++ [VarArg v | v <- vars])
  91 \end{code}
  92