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