{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables, FlexibleContexts,
FlexibleInstances #-}-- | Provides basic types and functions for other parts of /Copilot/.---- If you wish to add a new type, you need to make it an instance of @'Streamable'@,-- to add it to @'foldStreamableMaps'@, @'mapStreamableMaps'@, and optionnaly -- to add an ext[Type], a [type] and a var[Type]-- functions in Language.hs to make it easier to use. moduleLanguage.Copilot.Core(-- * Type hierarchy for the copilot languageVar,Name,Period,Phase,Port,Spec(..),Streams,Stream,Sends,Send(..),DistributedStreams,-- * General functions on 'Streams' and 'StreamableMaps'Streamable(..),Sendable(..),StreamableMaps(..),emptySM,isEmptySM,getMaybeElem,getElem,streamToUnitValue,foldStreamableMaps,foldSendableMaps,mapStreamableMaps,mapStreamableMapsM,filterStreamableMaps,normalizeVar,getVars,Vars-- Compiler,nextSt,BoundedArray(..),Outputs,TmpSamples,PhasedValue(..),ProphArrs,Indexes)whereimportqualifiedLanguage.AtomasAimportData.IntimportData.WordimportData.MaybeimportData.ListimportqualifiedData.MapasMimportText.PrintfimportControl.Monad.Writer---- Type hierarchy for the copilot language ------------------------------------- | Names of the streams or external variablestypeVar=String-- | C file nametypeName=String-- | Atom periodtypePeriod=Int-- | Phase of an Atom phasetypePhase=Int-- | Port over which to broadcast informationtypePort=Int-- | Specification of a stream, parameterized by the type of the values of the stream.-- The only requirement on @a@ is that it should be 'Streamable'.dataSpecawherePVar::Streamablea=>A.Type->Var->Phase->SpecaVar::Streamablea=>Var->SpecaConst::Streamablea=>a->SpecaF::(Streamablea,Streamableb)=>(b->a)->(A.Eb->A.Ea)->Specb->SpecaF2::(Streamablea,Streamableb,Streamablec)=>(b->c->a)->(A.Eb->A.Ec->A.Ea)->Specb->Specc->SpecaF3::(Streamablea,Streamableb,Streamablec,Streamabled)=>(b->c->d->a)->(A.Eb->A.Ec->A.Ed->A.Ea)->Specb->Specc->Specd->SpecaAppend::Streamablea=>[a]->Speca->SpecaDrop::Streamablea=>Int->Speca->Speca{-# RULES
"Copilot.Core appendAppend" forall ls1 ls2 s. Append ls1 (Append ls2 s) = Append (ls1 ++ ls2) s
"Copilot.Core dropDrop" forall i1 i2 s. Drop i1 (Drop i2 s) = Drop (i1 + i2) s
"Copilot.Core dropConst" forall i x. Drop i (Const x) = Const x
"Copilot.Core FConst" forall fI fC x0. F fI fC (Const x0) = Const (fI x0)
"Copilot.Core F2Const" forall fI fC x0 x1. F2 fI fC (Const x0) (Const x1) = Const (fI x0 x1)
"Copilot.Core F3Const" forall fI fC x0 x1 x2. F3 fI fC (Const x0) (Const x1) (Const x2) = Const (fI x0 x1 x2)
#-}instanceEqa=>Eq(Speca)where(==)(PVartvph)(PVart'v'ph')=t==t'&&v==v'&&ph==ph'(==)(Varv)(Varv')=v==v'(==)(Constx)(Constx')=x==x'(==)s@(F___)s'@(F___)=shows==shows'(==)s@(F2____)s'@(F2____)=shows==shows'(==)s@(F3_____)s'@(F3_____)=shows==shows'(==)(Appendlss)(Appendls's')=ls==ls'&&s==s'(==)(Dropis)(Dropi's')=i==i'&&s==s'(==)__=False-- | Container for mutually recursive streams, whose specifications may be-- parameterized by different types--type Streams = StreamableMaps SpectypeStreams=Writer(StreamableMapsSpec)()-- | A named streamtypeStreama=Streamablea=>(Var,Speca)-- | An instruction to send data on a port at a given phasedataSenda=Sendablea=>Send(Var,Phase,Port)-- | Container for all the instructions sending data, parameterised by different typestypeSends=StreamableMapsSend-- | Holds the complete specification of a distributed monitortypeDistributedStreams=(Streams,Sends)---- General functions on streams ------------------------------------------------ | A type is streamable iff a stream may emit values of that type-- -- There are very strong links between @'Streamable'@ and @'StreamableMaps'@ :-- the types aggregated in @'StreamableMaps'@ are exactly the @'Streamable'@ types-- and that invariant should be kept (see methods)class(A.Expra,A.Assigna,Showa)=>Streamableawhere-- | Provides access to the Map in a StreamableMaps which store values-- of the good typegetSubMap::StreamableMapsb->M.MapVar(ba)-- | Provides a way to modify (mostly used for insertions) the Map in a StreamableMaps-- which store values of the good typeupdateSubMap::(M.MapVar(ba)->M.MapVar(ba))->StreamableMapsb->StreamableMapsb-- | A default value for the type @a@. Its value is not important.unit::a-- | A constructor to produce an @Atom@ valueatomConstructor::Var->a->A.Atom(A.Va)-- | A constructor to get an @Atom@ value from an external variableexternalAtomConstructor::Var->A.Va-- | The argument only coerces the type, it is discarded.-- Returns the format for outputting a value of this type with printf in C---- For example "%f" for a floattypeId::a->String-- | The same, only adds the wanted precision for floating points.typeIdPrec::a->StringtypeIdPrecx=typeIdx-- | The argument only coerces the type, it is discarded.-- Returns the corresponding /Atom/ type.atomType::a->A.Type-- | Like Show, except that the formatting is exactly the same as the one of C-- for example the booleans are first converted to 0 or 1, and floats and doubles-- have the good precision.showAsC::a->String-- | To make customer C triggers. Only for Spec Bool (others through an error).makeTrigger::Maybe[(Var,String)]->StreamableMapsSpec->ProphArrs->TmpSamples->Indexes->Var->Speca->A.Atom()->A.Atom()classStreamablea=>Sendableawheresend::A.Ea->Port->A.Atom()instanceStreamableBoolwheregetSubMap=bMapupdateSubMapfsm=sm{bMap=f$bMapsm}unit=FalseatomConstructor=A.boolexternalAtomConstructor=A.bool'typeId_="%i"atomType_=A.BoolshowAsCx=printf"%u"(ifxthen1::Intelse0)makeTriggertriggersstreamsprophArrstmpSamplesoutputIndexesvsr=r>>iftrig/=""then(A.exactPhase0$A.atom("trigger__"++normalizeVarv)$doA.cond(nextStstreamsprophArrstmpSamplesoutputIndexess0)A.calltrig)elsereturn()wheretrigs=casetriggersofNothing->[]Justt->ttrig=caseM.lookupv(M.fromListtrigs)ofNothing->""Justfn->fninstanceStreamableInt8wheregetSubMap=i8MapupdateSubMapfsm=sm{i8Map=f$i8Mapsm}unit=0atomConstructor=A.int8externalAtomConstructor=A.int8'typeId_="%d"atomType_=A.Int8showAsCx=printf"%d"(toIntegerx)makeTriggertriggersstreamsprophArrstmpSamplesoutputIndexesvsr=r>>return()instanceStreamableInt16wheregetSubMap=i16MapupdateSubMapfsm=sm{i16Map=f$i16Mapsm}unit=0atomConstructor=A.int16externalAtomConstructor=A.int16'typeId_="%d"atomType_=A.Int16showAsCx=printf"%d"(toIntegerx)makeTriggertriggersstreamsprophArrstmpSamplesoutputIndexesvsr=r>>return()instanceStreamableInt32wheregetSubMap=i32MapupdateSubMapfsm=sm{i32Map=f$i32Mapsm}unit=0atomConstructor=A.int32externalAtomConstructor=A.int32'typeId_="%d"atomType_=A.Int32showAsCx=printf"%d"(toIntegerx)makeTriggertriggersstreamsprophArrstmpSamplesoutputIndexesvsr=r>>return()instanceStreamableInt64wheregetSubMap=i64MapupdateSubMapfsm=sm{i64Map=f$i64Mapsm}unit=0atomConstructor=A.int64externalAtomConstructor=A.int64'typeId_="%lld"atomType_=A.Int64showAsCx=printf"%d"(toIntegerx)makeTriggertriggersstreamsprophArrstmpSamplesoutputIndexesvsr=r>>return()instanceStreamableWord8wheregetSubMap=w8MapupdateSubMapfsm=sm{w8Map=f$w8Mapsm}unit=0atomConstructor=A.word8externalAtomConstructor=A.word8'typeId_="%u"atomType_=A.Word8showAsCx=printf"%u"(toIntegerx)makeTriggertriggersstreamsprophArrstmpSamplesoutputIndexesvsr=r>>return()instanceStreamableWord16wheregetSubMap=w16MapupdateSubMapfsm=sm{w16Map=f$w16Mapsm}unit=0atomConstructor=A.word16externalAtomConstructor=A.word16'typeId_="%u"atomType_=A.Word16showAsCx=printf"%u"(toIntegerx)makeTriggertriggersstreamsprophArrstmpSamplesoutputIndexesvsr=r>>return()instanceStreamableWord32wheregetSubMap=w32MapupdateSubMapfsm=sm{w32Map=f$w32Mapsm}unit=0atomConstructor=A.word32externalAtomConstructor=A.word32'typeId_="%u"atomType_=A.Word32showAsCx=printf"%u"(toIntegerx)makeTriggertriggersstreamsprophArrstmpSamplesoutputIndexesvsr=r>>return()instanceStreamableWord64wheregetSubMap=w64MapupdateSubMapfsm=sm{w64Map=f$w64Mapsm}unit=0atomConstructor=A.word64externalAtomConstructor=A.word64'typeId_="%llu"atomType_=A.Word64showAsCx=printf"%u"(toIntegerx)makeTriggertriggersstreamsprophArrstmpSamplesoutputIndexesvsr=r>>return()instanceStreamableFloatwheregetSubMap=fMapupdateSubMapfsm=sm{fMap=f$fMapsm}unit=0atomConstructor=A.floatexternalAtomConstructor=A.float'typeId_="%f"typeIdPrec_="%.5f"atomType_=A.FloatshowAsCx=printf"%.5f"xmakeTriggertriggersstreamsprophArrstmpSamplesoutputIndexesvsr=r>>return()instanceStreamableDoublewheregetSubMap=dMapupdateSubMapfsm=sm{dMap=f$dMapsm}unit=0atomConstructor=A.doubleexternalAtomConstructor=A.double'typeId_="%lf"typeIdPrec_="%.10lf"atomType_=A.DoubleshowAsCx=printf"%.10f"xmakeTriggertriggersstreamsprophArrstmpSamplesoutputIndexesvsr=r>>return()instanceSendableWord8wheresendeport=A.action(\[ueString]->"sendW8_port"++showport++"("++ueString++")")[A.uee]-- | Lookup into the map of the right type in @'StreamableMaps'@{-# INLINE getMaybeElem #-}getMaybeElem::Streamablea=>Var->StreamableMapsb->Maybe(ba)getMaybeElemvsm=M.lookupv$getSubMapsm-- | Lookup into the map of the right type in @'StreamableMaps'@-- Launch an exception if the index is not in it{-# INLINE getElem #-}getElem::Streamablea=>Var->StreamableMapsb->bagetElemvsm=fromJust$getMaybeElemvsm-- | Just produce an @Atom@ value named after its first argument,-- with an unspecified value. The second argument only coerces the type, it is discarded{-# INLINE streamToUnitValue #-}streamToUnitValue::Streamablea=>Var->Speca->A.Atom(A.Va)streamToUnitValuev_=atomConstructorvunit-- | This function is used to iterate on all the values in all the maps stored-- by a @'StreamableMaps'@, accumulating a value over time{-# INLINE foldStreamableMaps #-}foldStreamableMaps::forallbc.(foralla.Streamablea=>Var->ca->b->b)->StreamableMapsc->b->bfoldStreamableMapsf(SMbmi8mi16mi32mi64mw8mw16mw32mw64mfmdm)acc=letacc0=M.foldWithKeyfaccbmacc1=M.foldWithKeyfacc0i8macc2=M.foldWithKeyfacc1i16macc3=M.foldWithKeyfacc2i32macc4=M.foldWithKeyfacc3i64macc5=M.foldWithKeyfacc4w8macc6=M.foldWithKeyfacc5w16macc7=M.foldWithKeyfacc6w32macc8=M.foldWithKeyfacc7w64macc9=M.foldWithKeyfacc8fmacc10=M.foldWithKeyfacc9dminacc10-- | This function is used to iterate on all the values in all the maps stored-- by a @'StreamableMaps'@, accumulating a value over time{-# INLINE foldSendableMaps #-}foldSendableMaps::forallbc.(foralla.Sendablea=>Var->ca->b->b)->StreamableMapsc->b->bfoldSendableMapsf(SMbmi8mi16mi32mi64mw8mw16mw32mw64mfmdm)acc=letacc1=M.foldWithKeyfaccw8minacc1{-# INLINE mapStreamableMaps #-}mapStreamableMaps::forallss'.(foralla.Streamablea=>Var->sa->s'a)->StreamableMapss->StreamableMapss'mapStreamableMapsf(SMbmi8mi16mi32mi64mw8mw16mw32mw64mfmdm)=SM{bMap=M.mapWithKeyfbm,i8Map=M.mapWithKeyfi8m,i16Map=M.mapWithKeyfi16m,i32Map=M.mapWithKeyfi32m,i64Map=M.mapWithKeyfi64m,w8Map=M.mapWithKeyfw8m,w16Map=M.mapWithKeyfw16m,w32Map=M.mapWithKeyfw32m,w64Map=M.mapWithKeyfw64m,fMap=M.mapWithKeyffm,dMap=M.mapWithKeyfdm}{-# INLINE mapStreamableMapsM #-}mapStreamableMapsM::forallss'm.Monadm=>(foralla.Streamablea=>Var->sa->m(s'a))->StreamableMapss->m(StreamableMapss')mapStreamableMapsMfsm=foldStreamableMaps(\vssm'M->dosm'<-sm'Ms'<-fvsreturn$updateSubMap(\m->M.insertvs'm)sm')sm(returnemptySM)-- | Only keeps in @sm@ the values whose key+type are in @l@.-- Also returns a bool saying whether all the elements in sm-- were in l.-- Works even if some elements in @l@ are not in @sm@.-- Not optimised at allfilterStreamableMaps::forallc.StreamableMapsc->[(A.Type,Var,Phase)]->(StreamableMapsc,Bool)filterStreamableMapssml=let(sm2,l2)=foldStreamableMapsfilterElemsm(emptySM,[])in(sm2,(l'\\nubl2)==[])wherefilterElem::foralla.Streamablea=>Var->ca->(StreamableMapsc,[(A.Type,Var)])->(StreamableMapsc,[(A.Type,Var)])filterElemvs(sm',l2)=letx=(atomType(unit::a),v)inifx`elem`l'then(updateSubMap(\m->M.insertvsm)sm',x:l2)else(sm',l2)l'=nub$map(\(x,y,_)->(x,y))l-- | This is a generalization of @'Streams'@-- which is used for storing Maps over values parameterized by different types.---- It is extensively used in the internals of Copilot, in conjunction with-- @'foldStreamableMaps'@ and @'mapStreamableMaps'@dataStreamableMapsa=SM{bMap::M.MapVar(aBool),i8Map::M.MapVar(aInt8),i16Map::M.MapVar(aInt16),i32Map::M.MapVar(aInt32),i64Map::M.MapVar(aInt64),w8Map::M.MapVar(aWord8),w16Map::M.MapVar(aWord16),w32Map::M.MapVar(aWord32),w64Map::M.MapVar(aWord64),fMap::M.MapVar(aFloat),dMap::M.MapVar(aDouble)}instanceMonoid(StreamableMapsSpec)wheremempty=emptySMmappendx@(SMbmi8mi16mi32mi64mw8mw16mw32mw64mfmdm)y@(SMbm'i8m'i16m'i32m'i64m'w8m'w16m'w32m'w64m'fm'dm')=overlapwhereoverlap=letmultDefs=(getVarsx`intersect`getVarsy)inifnullmultDefsthenunionelseerror$"Copilot error: The variables "++showmultDefs++" have multiple definitions."union=SM(M.unionbmbm')(M.unioni8mi8m')(M.unioni16mi16m')(M.unioni32mi32m')(M.unioni64mi64m')(M.unionw8mw8m')(M.unionw16mw16m')(M.unionw32mw32m')(M.unionw64mw64m')(M.unionfmfm')(M.uniondmdm')-- | Get the Copilot variables.getVars::StreamableMapsSpec->[Var]getVarsstreams=foldStreamableMaps(\k_ks->k:ks)streams[]-- | An empty streamableMaps. emptySM::StreamableMapsaemptySM=SM{bMap=M.empty,i8Map=M.empty,i16Map=M.empty,i32Map=M.empty,i64Map=M.empty,w8Map=M.empty,w16Map=M.empty,w32Map=M.empty,w64Map=M.empty,fMap=M.empty,dMap=M.empty}-- | Verifies if its argument is equal to emptySMisEmptySM::StreamableMapsa->BoolisEmptySM(SMbmi8mi16mi32mi64mw8mw16mw32mw64mfmdm)=M.nullbm&&M.nulli8m&&M.nulli16m&&M.nulli32m&&M.nulli64m&&M.nullw8m&&M.nullw16m&&M.nullw32m&&M.nullw64m&&M.nullfm&&M.nulldm-- | Replace all accepted special characters by sequences of underscoresnormalizeVar::Var->VarnormalizeVarv=foldl(\accc->acc++casecof'.'->"__";'['->"___";']'->"____";_->[c])""v-- | For each typed variable, this type holds all its successive values in an infinite list-- Beware : each element of one of those lists corresponds to a full @Atom@ period, -- not to a single clock tick.typeVars=StreamableMaps[]-- Pretty printer: can't put in PrettyPrinter since that causes circular deps.instanceShowa=>Show(Speca)whereshows=showIndenteds0showIndented::Speca->Int->StringshowIndentedsn=lettabs=concat$replicaten" "intabs++showRawsnshowRaw::Speca->Int->StringshowRaw(PVartvph)_="PVar "++showt++" "++v++" "++showphshowRaw(Varv)_="Var "++vshowRaw(Conste)_="Const "++showeshowRaw(F__s0)n="F op? (\n"++showIndenteds0(n+1)++"\n"++(concat$replicaten" ")++")"showRaw(F2__s0s1)n="F2 op? (\n"++showIndenteds0(n+1)++"\n"++showIndenteds1(n+1)++"\n"++(concat$replicaten" ")++")"showRaw(F3__s0s1s2)n="F3 op? (\n"++showIndenteds0(n+1)++"\n"++showIndenteds1(n+1)++"\n"++showIndenteds2(n+1)++"\n"++(concat$replicaten" ")++")"showRaw(Appendlss0)n="Append "++showls++" (\n"++showIndenteds0(n+1)++"\n"++(concat$replicaten" ")++")"showRaw(Dropis0)n="Drop "++showi++" (\n"++showIndenteds0(n+1)++"\n"++(concat$replicaten" ")++")"-- Compiler: the code below really belongs in Core.hs, but its called by-- makeTrigger, which is a method of the class Streamable.typeArrIndex=Word64typeProphArrs=StreamableMapsBoundedArraytypeOutputs=StreamableMapsA.VtypeTmpSamples=StreamableMapsPhasedValuetypeIndexes=M.MapVar(A.VArrIndex)dataPhasedValuea=PhPhase(A.Va)-- important invariant : the maybe is Nothing iff the int is 0dataBoundedArraya=BArrIndex(Maybe(A.Aa))getValue::PhasedValuea->A.VagetValue(Ph_val)=valnextSt::Streamablea=>StreamableMapsSpec->ProphArrs->TmpSamples->Indexes->Speca->ArrIndex->A.EanextStstreamsprophArrstmpSamplesoutputIndexessindex=casesofPVar_vph->A.value.getValue$getElem(normalizeVarv++"_"++showph)tmpSamplesVarv->letBinitLenmaybeArr=getElemvprophArrsin-- This check is extremely important-- It means that if x at time n depends on y at time n-- then x is obtained not by y, but by inlining the definition of y-- so it increases the size of code (sadly),-- but is the only thing preventing race conditions from occuringifindex<initLen-- if maybeArr == Nothing, then initLen == 0 and is <= indexthenletoutputIndex=fromJust$M.lookupvoutputIndexesin(fromJustmaybeArr)A.!.((A.Constindex+A.VRefoutputIndex)`A.mod_`(A.Const(initLen+1)))elsenext(getElemvstreams)(index-initLen)Conste->A.ConsteF_fs0->f$nexts0indexF2_fs0s1->f(nexts0index)(nexts1index)F3_fs0s1s2->f(nexts0index)(nexts1index)(nexts2index)Append_s'->nexts'indexDropis'->nexts'(fromInteger(toIntegeri)+index)wherenext::Streamableb=>Specb->ArrIndex->A.Ebnext=nextStstreamsprophArrstmpSamplesoutputIndexes