Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch :
http://hackage.haskell.org/trac/ghc/changeset/76e2d6aebaeedd5a62168c9a047003649560a4df >--------------------------------------------------------------- commit 76e2d6aebaeedd5a62168c9a047003649560a4df Author: Max Bolingbroke <batterseapo...@hotmail.com> Date: Mon Feb 20 16:01:42 2012 +0000 Put Core-specific type-finding functions in the core module hierarchy >--------------------------------------------------------------- compiler/supercompile/Supercompile/Core/Syntax.hs | 50 ++++++++++++++++++-- .../supercompile/Supercompile/Evaluator/Syntax.hs | 35 +------------- 2 files changed, 46 insertions(+), 39 deletions(-) diff --git a/compiler/supercompile/Supercompile/Core/Syntax.hs b/compiler/supercompile/Supercompile/Core/Syntax.hs index c4d979b..44ed852 100644 --- a/compiler/supercompile/Supercompile/Core/Syntax.hs +++ b/compiler/supercompile/Supercompile/Core/Syntax.hs @@ -5,20 +5,24 @@ module Supercompile.Core.Syntax ( DataCon, Var, Literal, Type, PrimOp ) where +#include "HsVersions.h" + import Supercompile.Utilities import Supercompile.StaticFlags import OptCoercion import VarEnv (InScopeSet) -import DataCon (DataCon) +import DataCon (DataCon, dataConWorkId) import Var (TyVar, Var, varName, isTyVar, varType) import Name (Name, nameOccName) import OccName (occNameString) -import Id (Id) -import Literal (Literal) -import Type (Type, mkTyVarTy) -import Coercion (CoVar, Coercion, mkCvSubst, mkAxInstCo, mkReflCo, isReflCo) +import Id (Id, idType) +import PrimOp (primOpType) +import Literal (Literal, literalType) +import Type (Type, mkTyVarTy, applyTy, applyTys, mkForAllTy, mkFunTy, splitFunTy_maybe, eqType) +import Coercion (CoVar, Coercion, coercionType, coercionKind, mkCvSubst, mkAxInstCo, mkReflCo, isReflCo) import PrimOp (PrimOp) +import Pair (pSnd) import PprCore () @@ -253,6 +257,39 @@ castByCo Uncast = Nothing castByCo (CastBy co _) = Just co +valueType :: Copointed ann => ValueF ann -> Type +valueType (Indirect x) = idType x +valueType (TyLambda x e) = x `mkForAllTy` termType e +valueType (Lambda x e) = idType x `mkFunTy` termType e +valueType (Data dc as cos xs) = ((idType (dataConWorkId dc) `applyTys` as) `applyFunTys` map coercionType cos) `applyFunTys` map idType xs +valueType (Literal l) = literalType l +valueType (Coercion co) = coercionType co + +termType :: Copointed ann => ann (TermF ann) -> Type +termType = termType' . extract + +termType' :: Copointed ann => TermF ann -> Type +termType' e = case e of + Var x -> idType x + Value v -> valueType v + TyApp e a -> termType e `applyTy` a + CoApp e co -> termType e `applyFunTy` coercionType co + App e x -> termType e `applyFunTy` idType x + PrimOp pop tys es -> (primOpType pop `applyTys` tys) `applyFunTys` map termType es + Case _ _ ty _ -> ty + Let _ _ e -> termType e + LetRec _ e -> termType e + Cast _ co -> pSnd (coercionKind co) + +applyFunTy :: Type -> Type -> Type +applyFunTy fun_ty got_arg_ty = case splitFunTy_maybe fun_ty of + Just (expected_arg_ty, res_ty) -> ASSERT2(got_arg_ty `eqType` expected_arg_ty, text "applyFunTy:" <+> ppr got_arg_ty <+> ppr expected_arg_ty) res_ty + Nothing -> pprPanic "applyFunTy" (ppr fun_ty $$ ppr got_arg_ty) + +applyFunTys :: Type -> [Type] -> Type +applyFunTys = foldl' applyFunTy + + class Functor ann => Symantics ann where var :: Var -> ann (TermF ann) value :: ValueF ann -> ann (TermF ann) @@ -334,6 +371,9 @@ tyVarIdLambda x e | isTyVar x = value $ TyLambda x e tyApps :: Symantics ann => ann (TermF ann) -> [Type] -> ann (TermF ann) tyApps = foldl tyApp +coApps :: Symantics ann => ann (TermF ann) -> [Coercion] -> ann (TermF ann) +coApps = foldl coApp + apps :: Symantics ann => ann (TermF ann) -> [Id] -> ann (TermF ann) apps = foldl app diff --git a/compiler/supercompile/Supercompile/Evaluator/Syntax.hs b/compiler/supercompile/Supercompile/Evaluator/Syntax.hs index 9faa99a..a8cfb1a 100644 --- a/compiler/supercompile/Supercompile/Evaluator/Syntax.hs +++ b/compiler/supercompile/Supercompile/Evaluator/Syntax.hs @@ -15,10 +15,8 @@ import Supercompile.Utilities import Id (Id, idType) import PrimOp (primOpType) -import Type (applyTy, applyTys, mkForAllTy, mkFunTy, splitFunTy, eqType, isUnLiftedType) +import Type (applyTy, applyTys, isUnLiftedType) import Pair (pSnd) -import DataCon (dataConWorkId) -import Literal (literalType) import Coercion (coercionType, coercionKind) import qualified Data.Map as M @@ -282,37 +280,6 @@ answerType a = case annee a of (CastBy co _, _) -> pSnd (coercionKind co) (Uncast, (rn, v)) -> valueType (renameAnnedValue' (mkInScopeSet (annedFreeVars a)) rn v) -valueType :: Copointed ann => ValueF ann -> Type -valueType (Indirect x) = idType x -valueType (TyLambda x e) = x `mkForAllTy` termType e -valueType (Lambda x e) = idType x `mkFunTy` termType e -valueType (Data dc as cos xs) = ((idType (dataConWorkId dc) `applyTys` as) `applyFunTys` map coercionType cos) `applyFunTys` map idType xs -valueType (Literal l) = literalType l -valueType (Coercion co) = coercionType co - -termType :: Copointed ann => ann (TermF ann) -> Type -termType = termType' . extract - -termType' :: Copointed ann => TermF ann -> Type -termType' e = case e of - Var x -> idType x - Value v -> valueType v - TyApp e a -> termType e `applyTy` a - CoApp e co -> termType e `applyFunTy` coercionType co - App e x -> termType e `applyFunTy` idType x - PrimOp pop tys es -> (primOpType pop `applyTys` tys) `applyFunTys` map termType es - Case _ _ ty _ -> ty - Let _ _ e -> termType e - LetRec _ e -> termType e - Cast _ co -> pSnd (coercionKind co) - -applyFunTy :: Type -> Type -> Type -applyFunTy fun_ty got_arg_ty = ASSERT2(got_arg_ty `eqType` expected_arg_ty, text "applyFunTy:" <+> ppr got_arg_ty <+> ppr expected_arg_ty) res_ty - where (expected_arg_ty, res_ty) = splitFunTy fun_ty - -applyFunTys :: Type -> [Type] -> Type -applyFunTys = foldl' applyFunTy - heapBindingTerm :: HeapBinding -> Maybe (In AnnedTerm) heapBindingTerm = either (const Nothing) Just . heapBindingMeaning _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
