{-# LANGUAGE GADTs #-}{-# LANGUAGE RankNTypes #-}{-# LANGUAGE ViewPatterns #-}{-# LANGUAGE TypeFamilies #-}{-# LANGUAGE TypeOperators #-}{-# LANGUAGE FlexibleContexts #-}{-# LANGUAGE FlexibleInstances #-}{-# LANGUAGE ScopedTypeVariables #-}{-# LANGUAGE MultiParamTypeClasses #-}{-# LANGUAGE ConstraintKinds #-}---- Copyright (c) 2009-2011, ERICSSON AB-- All rights reserved.---- Redistribution and use in source and binary forms, with or without-- modification, are permitted provided that the following conditions are met:---- * Redistributions of source code must retain the above copyright notice,-- this list of conditions and the following disclaimer.-- * Redistributions in binary form must reproduce the above copyright-- notice, this list of conditions and the following disclaimer in the-- documentation and/or other materials provided with the distribution.-- * Neither the name of the ERICSSON AB nor the names of its contributors-- may be used to endorse or promote products derived from this software-- without specific prior written permission.---- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.--{-# LANGUAGE UndecidableInstances #-}-- | Defines different interpretations of Feldspar programsmoduleFeldspar.Core.Interpretation(moduleLanguage.Syntactic.Constructs.Decoration,moduleFeldspar.Core.Interpretation.Typed,targetSpecialization,Sharable(..),SizeProp(..),sizePropDefault,resultType,SourceInfo,Info(..),mkInfo,mkInfoTy,infoRange,LatticeSize1(..),viewLiteral,literalDecor,constFold,SomeInfo(..),SomeType(..),Env(..),localVar,localSource,Opt,Optimize(..),OptimizeSuper,constructFeat,optimizeM,optimize,constructFeatUnOptDefaultTyp,constructFeatUnOptDefault,optimizeFeatDefault,prjF,c')whereimportControl.Monad.ReaderimportData.MapasMapimportData.Typeable(Typeable)importLanguage.SyntacticimportLanguage.Syntactic.Constructs.DecorationimportLanguage.Syntactic.Constructs.LiteralimportLanguage.Syntactic.Constructs.BindingimportLanguage.Syntactic.Constructs.Binding.HigherOrderimportFeldspar.LatticeimportFeldspar.Core.TypesimportFeldspar.Core.Interpretation.Typed---------------------------------------------------------------------------------- * Target specialization---------------------------------------------------------------------------------- | Specialize the program for a target platform with the given native bit-- widthtargetSpecialization::BitWidthn->ASTFdoma->ASTFdoma-- TODO targetSpecialization :: BitWidth n -> ASTF dom a -> ASTF dom (TargetType n a)targetSpecialization_=id---------------------------------------------------------------------------------- * Code motion---------------------------------------------------------------------------------- | Indication whether a symbol is sharable or notclassSharabledomwheresharable::doma->Boolsharable_=Trueinstance(Sharablesub1,Sharablesub2)=>Sharable(sub1:+:sub2)wheresharable(InjLa)=sharableasharable(InjRa)=sharableainstanceSharablesym=>Sharable(sym:||pred)wheresharable(C's)=sharablesinstanceSharablesym=>Sharable(SubConstr2csymp1p2)wheresharable(SubConstr2s)=sharablesinstanceSharabledom=>Sharable(DecorInfodom)wheresharable=sharable.decorExprinstanceSharableEmpty---------------------------------------------------------------------------------- * Size propagation---------------------------------------------------------------------------------- | Forwards size propagationclassSizePropfeaturewhere-- | Size propagation for a symbol given a list of argument sizessizeProp::featurea->Args(WrapFullInfo)a->Size(DenResulta)-- | Convenient default implementation of 'sizeProp'sizePropDefault::(Type(DenResulta))=>featurea->Args(WrapFullInfo)a->Size(DenResulta)sizePropDefault__=universal---------------------------------------------------------------------------------- * Optimization and type/size inference---------------------------------------------------------------------------------- | Compute a type representation of a symbol's result typeresultType::Type(DenResulta)=>ca->TypeRep(DenResulta)resultType_=typeRepdataSomeTypewhereSomeType::TypeRepa->SomeTypetypeVarInfo=MapVarIdSomeType-- | Information about the source code of an expressiontypeSourceInfo=String-- | Type and size information of a Feldspar programdataInfoawhereInfo::Show(Sizea)=>{infoType::TypeRepa,infoSize::Sizea,infoVars::VarInfo,infoSource::SourceInfo}->InfoainstanceRenderInfowhererenderi@(Info{})=show(infoTypei)++szStr++srcStrwhereszStr=caseshow(infoSizei)of"()"->""-- TODO AnySizestr->" | "++strsrcStr=caseinfoSourceiof""->""src->" | "++srcinstanceEq(Sizea)=>Eq(Infoa)whereia==ib=infoSizeia==infoSizeib-- TODOmkInfo::Typea=>Sizea->InfoamkInfosz=InfotypeRepszMap.empty""mkInfoTy::(Show(Sizea),Lattice(Sizea))=>TypeRepa->InfoamkInfoTyt=InfotuniversalMap.empty""infoRange::Typea=>Infoa->RangeSetainfoRange=sizeToRange.infoSize-- | This class is used to allow constructs to be abstract in the monad. Its-- purpose is similar to that of 'MonadType'.classLatticeSize1mwheremergeSize::Lattice(Sizea)=>Info(ma)->Size(ma)->Size(ma)->Size(ma)-- TODO Is this class needed? See comment to `MonadType`.instanceLatticeSize1MutwheremergeSize_=(\/)-- | 'Info' with hidden result typedataSomeInfowhereSomeInfo::Typeablea=>Infoa->SomeInfodataEnv=Env{varEnv::[(VarId,SomeInfo)],sourceEnv::SourceInfo}-- | Initial environmentinitEnv::EnvinitEnv=Env[]""-- | Insert a variable into the environmentlocalVar::Typeableb=>VarId->Infob->Opta->OptalocalVarvinfo=local$\env->env{varEnv=(v,SomeInfoinfo):varEnvenv}-- | Change the 'SourceInfo' environmentlocalSource::SourceInfo->Opta->OptalocalSourcesrc=local$\env->env{sourceEnv=src}-- | It the expression is a literal, its value is returned, otherwise 'Nothing'viewLiteral::forallinfodoma.((Literal:||Type):<:dom)=>ASTF(Decorinfo(dom:||Typeable))a->MaybeaviewLiteral(prjF->Just(C'(Literala)))=JustaviewLiteral_=NothingprjF::Project(sub:||Type)sup=>supsig->Maybe((sub:||Type)sig)prjF=prj-- | Construct a 'Literal' decorated with 'Info'literalDecorSrc::(Typea,(Literal:||Type):<:dom)=>SourceInfo->a->ASTF(DecorInfo(dom:||Typeable))aliteralDecorSrcsrca=Sym$Decor((mkInfo(sizeOfa)){infoSource=src})(C'$inj$c'$Literala)c'::(Type(DenResultsig))=>featuresig->(feature:||Type)sigc'=C'-- | Construct a 'Literal' decorated with 'Info'literalDecor::(Typea,(Literal:||Type):<:dom)=>a->ASTF(DecorInfo(dom:||Typeable))aliteralDecor=literalDecorSrc""-- Note: This function could get the 'SourceInfo' from the environment and-- insert it in the 'infoSource' field. But then it needs to be monadic which-- makes optimizations uglier.-- | Replaces an expression with a literal if the type permits, otherwise-- returns the expression unchanged.constFold::(Typeddom,(Literal:||Type):<:dom)=>SourceInfo->ASTF(DecorInfo(dom:||Typeable))a->a->ASTF(DecorInfo(dom:||Typeable))aconstFoldsrcexpra|JustDict<-typeDictexpr=literalDecorSrcsrcaconstFold_expr_=expr-- | Environment for optimizationtypeOpt=ReaderEnv-- | Basic optimization of a feature---- This optimization is similar to 'Synt.Optimize', but it also performs size-- inference. Size inference has to be done simultaneously with other-- optimizations in order to avoid iterating the phases. (Size information may-- help optimization and optimization may help size inference.)classOptimizefeaturedomwhere-- | Top-down and bottom-up optimization of a featureoptimizeFeat::(Typeable(DenResulta),OptimizeSuperdom)=>featurea->Args(AST(dom:||Typeable))a->Opt(ASTF(DecorInfo(dom:||Typeable))(DenResulta))optimizeFeat=optimizeFeatDefault-- | Optimized construction of an expression from a symbol and its optimized-- arguments---- Note: This function should normally not be called directly. Instead, use-- 'constructFeat' which has more accurate propagation of 'Info'.constructFeatOpt::(Typeable(DenResulta))=>featurea->Args(AST(DecorInfo(dom:||Typeable)))a->Opt(ASTF(DecorInfo(dom:||Typeable))(DenResulta))constructFeatOpt=constructFeatUnOpt-- | Unoptimized construction of an expression from a symbol and its-- optimized argumentsconstructFeatUnOpt::(Typeable(DenResulta))=>featurea->Args(AST(DecorInfo(dom:||Typeable)))a->Opt(ASTF(DecorInfo(dom:||Typeable))(DenResulta))instanceOptimizeEmptydomwhereconstructFeatUnOpt=error"Not implemented: constructFeatUnOpt for Empty"-- These classes used to be super-classes of `Optimize`, but after switching to-- GHC 7.4, that lead to looping dictionaries (at run time). The problem arises-- when you make instances like---- instance Optimize dom dom => Optimize MyConstruct dom---- Since the second parameter does not change, this seems to create a loop-- whenever you want to access super-class methods through a-- `Optimize MyConstruct dom` constraint.---- This may or may not be related to the following (unconfirmed) bug:---- http://hackage.haskell.org/trac/ghc/ticket/5913---- To revert the class hierarchy:---- * Make `OptimizeSuper` (expanded) a super-class of `Optimize`-- * Make `WitnessCons feature` a super-class of `Optimize`-- * Replace the context of `optimizeFeat` with `Optimize dom dom`-- * Replace all references to `OptimizeSuper dom` with `Optimize dom dom`-- * Remove `OptimizeSuper`class(AlphaEqdomdom(dom:||Typeable)[(VarId,VarId)],AlphaEqdomdom(DecorInfo(dom:||Typeable))[(VarId,VarId)],EvalBinddom,(Literal:||Type):<:dom,Typeddom,Constraineddom,Optimizedomdom)=>OptimizeSuperdominstance(AlphaEqdomdom(dom:||Typeable)[(VarId,VarId)],AlphaEqdomdom(DecorInfo(dom:||Typeable))[(VarId,VarId)],EvalBinddom,(Literal:||Type):<:dom,Typeddom,Constraineddom,Optimizedomdom)=>OptimizeSuperdom-- TODO Optimization should throw an error when the size of a node is-- over-constrained. It can only happen if there's a bug in the general-- size inference, or if the user has stated invalid size constraints. In-- both cases it may lead to incorrect optimizations, so throwing an error-- seems preferable.-- | Optimized construction of an expression from a symbol and its optimized-- argumentsconstructFeat::(Typeable(DenResulta),Optimizefeaturedom)=>featurea->Args(AST(DecorInfo(dom:||Typeable)))a->Opt(ASTF(DecorInfo(dom:||Typeable))(DenResulta))constructFeataargs=doaUnOpt<-constructFeatUnOptaargsaOpt<-constructFeatOptaargsreturn$updateDecor(\info->info{infoSize=infoSize(getInfoaUnOpt)})aOpt-- This function uses `constructFeatOpt` for optimization and-- `constructFeatUnOpt` for size propagation. This is because-- `constructFeatOpt` may produce less accurate size information than-- `constructFeatUnOpt`.-- TODO It might be better to use `sizeProp` instead of `constructFeatUnOpt`-- (but this changes class dependencies a bit). Is there any other use of-- `constructFeatUnOpt`?instance(Optimizesub1dom,Optimizesub2dom)=>Optimize(sub1:+:sub2)domwhereoptimizeFeat(InjLa)=optimizeFeataoptimizeFeat(InjRa)=optimizeFeataconstructFeatOpt(InjLa)=constructFeatOptaconstructFeatOpt(InjRa)=constructFeatOptaconstructFeatUnOpt(InjLa)=constructFeatUnOptaconstructFeatUnOpt(InjRa)=constructFeatUnOpta-- | Optimization of an expression---- In addition to running 'optimizeFeat', this function performs constant-- folding on all closed expressions, provided that the type permits making a-- literal.optimizeM::(OptimizeSuperdom)=>ASTF(dom:||Typeable)a->Opt(ASTF(DecorInfo(dom:||Typeable))a)optimizeMa|Dict<-exprDicta=doaOpt<-matchTrans(\(C'x)->optimizeFeatx)aletvars=infoVars$getInfoaOptvalue=evalBindaOptsrc=infoSource$getInfoaOpt-- return aOptifMap.nullvarsthenreturn$constFoldsrcaOptvalueelsereturnaOpt-- TODO singleton range --> literal-- literal --> singleton range-- | Optimization of an expression. This function runs 'optimizeM' and extracts-- the result.optimize::(Typeablea,OptimizeSuperdom)=>ASTF(dom:||Typeable)a->ASTF(DecorInfo(dom:||Typeable))aoptimize=fliprunReaderinitEnv.optimizeM-- | Convenient default implementation of 'constructFeatUnOpt'. Uses 'sizeProp'-- to propagate size.constructFeatUnOptDefaultTyp::(feature:<:dom,SizePropfeature,Typeable(DenResulta),Show(Size(DenResulta)))=>TypeRep(DenResulta)->featurea->Args(AST(DecorInfo(dom:||Typeable)))a->Opt(ASTF(DecorInfo(dom:||Typeable))(DenResulta))constructFeatUnOptDefaultTyptypfeatargs=dosrc<-askssourceEnvletsz=sizePropfeat$mapArgs(WrapFull.getInfo)argsvars=Map.unions$listArgs(infoVars.getInfo)argsreturn$appArgs(Sym$Decor(Infotypszvarssrc)$C'$injfeat)args-- | Like 'constructFeatUnOptDefaultTyp' but without an explicit 'TypeRep'constructFeatUnOptDefault::(feature:<:dom,SizePropfeature,Type(DenResulta))=>featurea->Args(AST(DecorInfo(dom:||Typeable)))a->Opt(ASTF(DecorInfo(dom:||Typeable))(DenResulta))constructFeatUnOptDefaultfeatargs=dosrc<-askssourceEnvletsz=sizePropfeat$mapArgs(WrapFull.getInfo)argsvars=Map.unions$listArgs(infoVars.getInfo)argsreturn$appArgs(Sym$Decor(InfotypeRepszvarssrc)$C'$injfeat)args-- | Convenient default implementation of 'optimizeFeat'optimizeFeatDefault::(Optimizefeaturedom,Typeable(DenResulta),OptimizeSuperdom)=>featurea->Args(AST(dom:||Typeable))a->Opt(ASTF(DecorInfo(dom:||Typeable))(DenResulta))optimizeFeatDefaultfeatargs=constructFeatfeat=<<mapArgsMoptimizeMargs