[project @ 1996-07-25 20:43:49 by partain]

[ghc-hetmet.git] / ghc / compiler / specialise / Specialise.lhs

diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs
index 4a87887..8164e0c 100644 (file)
--- a/ghc/compiler/specialise/Specialise.lhs
+++ b/ghc/compiler/specialise/Specialise.lhs
@@ -13,31 +13,33 @@ module Specialise (
        SpecialiseData(..)
     ) where
 
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
+IMPORT_1_3(List(partition))
 
 import Bag             ( emptyBag, unitBag, isEmptyBag, unionBags,
                          partitionBag, listToBag, bagToList
                        )
 import Class           ( GenClass{-instance Eq-} )
 import CmdLineOpts     ( opt_SpecialiseImports, opt_D_simplifier_stats,
-                         opt_CompilingPrelude, opt_SpecialiseTrace,
+                         opt_CompilingGhcInternals, opt_SpecialiseTrace,
                          opt_SpecialiseOverloaded, opt_SpecialiseUnboxed,
                          opt_SpecialiseAll
                        )
 import CoreLift                ( mkLiftedId, liftExpr, bindUnlift, applyBindUnlifts )
 import CoreSyn
 import CoreUtils       ( coreExprType, squashableDictishCcExpr )
-import FiniteMap       ( addListToFM_C )
+import FiniteMap       ( addListToFM_C, FiniteMap )
+import Kind            ( mkBoxedTypeKind )
 import Id              ( idType, isDefaultMethodId_maybe, toplevelishId,
                          isSuperDictSelId_maybe, isBottomingId,
                          isConstMethodId_maybe, isDataCon,
                          isImportedId, mkIdWithNewUniq,
                          dataConTyCon, applyTypeEnvToId,
                          nullIdEnv, addOneToIdEnv, growIdEnvList,
-                         lookupIdEnv, IdEnv(..),
+                         lookupIdEnv, SYN_IE(IdEnv),
                          emptyIdSet, mkIdSet, unitIdSet,
                          elementOfIdSet, minusIdSet,
-                         unionIdSets, unionManyIdSets, IdSet(..),
+                         unionIdSets, unionManyIdSets, SYN_IE(IdSet),
                          GenId{-instance Eq-}
                        )
 import Literal         ( Literal{-instance Outputable-} )
@@ -49,9 +51,8 @@ import PprType                ( pprGenType, pprParendGenType, pprMaybeTy,
                          GenType{-instance Outputable-}, GenTyVar{-ditto-},
                          TyCon{-ditto-}
                        )
-import PrelInfo                ( liftDataCon )
 import Pretty          ( ppHang, ppCat, ppStr, ppAboves, ppBesides,
-                         ppInt, ppSP, ppInterleave, ppNil, Pretty(..)
+                         ppInt, ppSP, ppInterleave, ppNil, SYN_IE(Pretty)
                        )
 import PrimOp          ( PrimOp(..) )
 import SpecUtils
@@ -59,11 +60,12 @@ import Type         ( mkTyVarTy, mkTyVarTys, isTyVarTy, getAppDataTyConExpandingDicts,
                          tyVarsOfTypes, applyTypeEnvToTy, isUnboxedType
                        )
 import TyCon           ( TyCon{-instance Eq-} )
-import TyVar           ( cloneTyVar,
-                         elementOfTyVarSet, TyVarSet(..),
-                         nullTyVarEnv, growTyVarEnvList, TyVarEnv(..),
+import TyVar           ( cloneTyVar, mkSysTyVar,
+                         elementOfTyVarSet, SYN_IE(TyVarSet),
+                         nullTyVarEnv, growTyVarEnvList, SYN_IE(TyVarEnv),
                          GenTyVar{-instance Eq-}
                        )
+import TysWiredIn      ( liftDataCon )
 import Unique          ( Unique{-instance Eq-} )
 import UniqSet         ( mkUniqSet, unionUniqSets, uniqSetToList )
 import UniqSupply      ( splitUniqSupply, getUniques, getUnique )
@@ -75,7 +77,7 @@ infixr 9 `thenSM`
 
 --ToDo:kill
 data SpecInfo = SpecInfo [Maybe Type] Int Id
-
+lookupSpecEnv = panic "Specialise.lookupSpecEnv (ToDo)"
 addIdSpecialisation = panic "Specialise.addIdSpecialisation (ToDo)"
 cmpUniTypeMaybeList = panic "Specialise.cmpUniTypeMaybeList (ToDo)"
 getIdSpecialisation = panic "Specialise.getIdSpecialisation (ToDo)"
@@ -86,8 +88,6 @@ isLocalSpecTyCon = panic "Specialise.isLocalSpecTyCon (ToDo)"
 isSpecId_maybe = panic "Specialise.isSpecId_maybe (ToDo)"
 isSpecPragmaId_maybe = panic "Specialise.isSpecPragmaId_maybe (ToDo)"
 lookupClassInstAtSimpleType = panic "Specialise.lookupClassInstAtSimpleType (ToDo)"
-lookupSpecEnv = panic "Specialise.lookupSpecEnv (ToDo)"
-mkPolySysTyVar = panic "Specialise.mkPolySysTyVar (ToDo)"
 mkSpecEnv = panic "Specialise.mkSpecEnv (ToDo)"
 mkSpecId = panic "Specialise.mkSpecId (ToDo)"
 selectIdInfoForSpecId = panic "Specialise.selectIdInfoForSpecId (ToDo)"
@@ -929,11 +929,11 @@ emptyUDs    :: UsageDetails
 unionUDs    :: UsageDetails -> UsageDetails -> UsageDetails
 unionUDList :: [UsageDetails] -> UsageDetails
 
-tickSpecCall :: Bool -> UsageDetails -> UsageDetails
+-- tickSpecCall :: Bool -> UsageDetails -> UsageDetails
 tickSpecInsts :: UsageDetails -> UsageDetails
 
-tickSpecCall found (UsageDetails cis ty_cis dbs fvs c i)
- = UsageDetails cis ty_cis dbs fvs (c + (if found then 1 else 0)) i
+-- tickSpecCall found (UsageDetails cis ty_cis dbs fvs c i)
+-- = UsageDetails cis ty_cis dbs fvs (c + (if found then 1 else 0)) i
 
 tickSpecInsts (UsageDetails cis ty_cis dbs fvs c i)
  = UsageDetails cis ty_cis dbs fvs c (i+1)
@@ -1198,7 +1198,7 @@ specTyConsAndScope scopeM
   = scopeM                     `thenSM` \ (binds, scope_uds) ->
     let
        (tycons_cis, gotci_scope_uds)
-        = getLocalSpecTyConIs opt_CompilingPrelude scope_uds
+        = getLocalSpecTyConIs opt_CompilingGhcInternals scope_uds
 
        tycon_specs_list = collectTyConSpecs tycons_cis
     in
@@ -1297,14 +1297,14 @@ specExpr (Var v) args
        NoLift vatom@(VarArg new_v)
             -> mapSM specOutArg args                   `thenSM` \ arg_info ->
                mkCallInstance v new_v arg_info         `thenSM` \ call_uds ->
-               mkCall new_v arg_info                   `thenSM` \ ~(speced, call) ->
+               mkCall new_v arg_info                   `thenSM` \ call ->
                let
                    uds = unionUDList [call_uds,
                                       singleFvUDs vatom,
                                       unionUDList [uds | (_,uds,_) <- arg_info]
                                      ]
                in
-               returnSM (call, tickSpecCall speced uds)
+               returnSM (call, {- tickSpecCall speced -} uds)
 
 specExpr expr@(Lit _) null_args
   = ASSERT (null null_args)
@@ -1531,7 +1531,8 @@ specAlts (AlgAlts alts deflt) scrutinee_ty args
     -- We use ty_args of scrutinee type to identify specialisation of
     -- alternatives:
 
-    (_, ty_args, _) = getAppDataTyConExpandingDicts scrutinee_ty
+    (_, ty_args, _) = --trace "Specialise.specAlts:getAppData..." $
+                     getAppDataTyConExpandingDicts scrutinee_ty
 
     specAlgAlt ty_args (con,binders,rhs)
       = specLambdaOrCaseBody binders rhs args  `thenSM` \ (binders, rhs, rhs_uds) ->
@@ -1974,7 +1975,7 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis
                -- "required" by one of the other Ids in the Rec
          | top_lev && maybeToBool lookup_orig_spec
          = (if opt_SpecialiseTrace
-            then trace_nospec "  Exists: " exists_id
+            then trace_nospec "  Exists: " orig_id
             else id) (
 
            returnSM (Nothing, emptyUDs, Nothing)
@@ -2022,7 +2023,6 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis
                          tickSpecInsts final_uds, spec_info)
          where
            lookup_orig_spec = lookupSpecEnv (getIdSpecialisation orig_id) arg_tys
-           Just (exists_id, _, _) = lookup_orig_spec
 
            explicit_cis_for_this_id = filter (isCIofTheseIds [new_id]) explicit_cis
            [CallInstance _ _ _ _ (Just explicit_spec_info)] = explicit_cis_for_this_id
@@ -2198,9 +2198,11 @@ take_dict_args [] args = Just ([], args)
 \begin{code}
 mkCall :: Id
        -> [(CoreArg, UsageDetails, CoreExpr -> CoreExpr)]
-       -> SpecM (Bool, CoreExpr)
+       -> SpecM CoreExpr
 
-mkCall new_id args
+mkCall new_id arg_infos = returnSM (mkGenApp (Var new_id) [arg | (arg, _, _) <- arg_infos])
+
+{- 
   | maybeToBool (isSuperDictSelId_maybe new_id)
     && any isUnboxedType ty_args
        -- No specialisations for super-dict selectors
@@ -2307,6 +2309,7 @@ checkSpecOK check_id tys spec_id tys_left
                             ppCat [ppr PprDebug spec_id,
                                    ppInterleave ppNil (map (pprParendGenType PprDebug) tys_left)]])
     else id
+-}
 \end{code}
 
 \begin{code}
@@ -2418,10 +2421,8 @@ newSpecIds new_ids maybe_tys dicts_to_ignore tvenv idenv us
     spec_id_ty id = specialiseTy (idType id) maybe_tys dicts_to_ignore
 
 newTyVars :: Int -> SpecM [TyVar]
-newTyVars n tvenv idenv us
- = map mkPolySysTyVar uniqs
- where
-   uniqs = getUniques n us
+newTyVars n tvenv idenv us 
+  = [mkSysTyVar uniq mkBoxedTypeKind | uniq <- getUniques n us]
 \end{code}
 
 @cloneLambdaOrCaseBinders@ and @cloneLetBinders@ take a bunch of