{-# LANGUAGE MultiParamTypeClasses #-}{-# LANGUAGE FunctionalDependencies #-}{-# LANGUAGE UndecidableInstances #-}{-# LANGUAGE FlexibleInstances #-}{-# LANGUAGE FlexibleContexts #-}moduleLLVM.Extra.Memory(C(load,store,decompose,compose),modify,castStorablePtr,Record,Element,element,loadRecord,storeRecord,decomposeRecord,composeRecord,loadNewtype,storeNewtype,decomposeNewtype,composeNewtype,FirstClass,)whereimportLLVM.Extra.Class(MakeValueTuple,Undefined,)importqualifiedLLVM.Extra.ArithmeticPrivateasAimportqualifiedLLVM.Extra.VectorasVectorimportqualifiedLLVM.Extra.ArrayasArrayimportqualifiedLLVM.CoreasLLVMimportLLVM.Core(Struct,getElementPtr0,extractvalue,insertvalue,Value,-- valueOf, Vector,IsType,IsSized,CodeGenFunction,)importLLVM.Util.Loop(Phi,)importqualifiedData.TypeLevel.NumasTypeNumimportData.TypeLevel.Num(d0,d1,d2,)importForeign.StablePtr(StablePtr,)importForeign.Ptr(Ptr,castPtr,)importData.Word(Word8,Word16,Word32,Word64,)importData.Int(Int8,Int16,Int32,Int64,)importControl.Monad(ap,)importControl.Applicative(pure,liftA2,liftA3,)importqualifiedControl.ApplicativeasAppimportData.Tuple.HT(fst3,snd3,thd3,){- |
An implementation of both 'MakeValueTuple' and 'Memory.C'
must ensure that @haskellValue@ is compatible with @llvmStruct@.
That is, writing and reading @llvmStruct@ by LLVM
must be the same as accessing @haskellValue@ by 'Storable' methods.
ToDo: In future we may also require Storable constraint for llvmStruct.
We use a functional dependency in order to let type inference work nicely.
-}class(PhillvmValue,UndefinedllvmValue,IsTypellvmStruct)=>CllvmValuellvmStruct|llvmValue->llvmStructwhereload::Value(PtrllvmStruct)->CodeGenFunctionrllvmValueloadptr=decompose=<<LLVM.loadptrstore::llvmValue->Value(PtrllvmStruct)->CodeGenFunctionr()storerptr=flipLLVM.storeptr=<<composerdecompose::ValuellvmStruct->CodeGenFunctionrllvmValuecompose::llvmValue->CodeGenFunctionr(ValuellvmStruct)modify::(CllvmValuellvmStruct)=>(llvmValue->CodeGenFunctionrllvmValue)->Value(PtrllvmStruct)->CodeGenFunctionr()modifyfptr=flipstoreptr=<<f=<<loadptrtypeRecordrov=ElementrovvdataElementrovx=Element{loadElement::Value(Ptro)->CodeGenFunctionrx,storeElement::Value(Ptro)->v->CodeGenFunctionr(),extractElement::Valueo->CodeGenFunctionrx,insertElement::v->Valueo->CodeGenFunctionr(Valueo)-- State.Monoid}element::(CxllvmStruct,LLVM.GetValueonllvmStruct,LLVM.GetElementPtro(n,())llvmStruct)=>(v->x)->n->Elementrovxelementfieldn=Element{loadElement=\ptr->load=<<getElementPtr0ptr(n,()),storeElement=\ptrv->store(fieldv)=<<getElementPtr0ptr(n,()),extractElement=\o->decompose=<<extractvalueon,insertElement=\vo->flip(insertvalueo)n=<<compose(fieldv)}instanceFunctor(Elementrov)wherefmapfm=Element{loadElement=fmapf.loadElementm,storeElement=storeElementm,extractElement=fmapf.extractElementm,insertElement=insertElementm}instanceApp.Applicative(Elementrov)wherepurex=Element{loadElement=\_ptr->returnx,storeElement=\_ptr_v->return(),extractElement=\_o->returnx,insertElement=\_vo->returno}f<*>x=Element{loadElement=\ptr->loadElementfptr`ap`loadElementxptr,storeElement=\ptry->storeElementfptry>>storeElementxptry,extractElement=\o->extractElementfo`ap`extractElementxo,insertElement=\yo->insertElementfyo>>=insertElementxy}loadRecord::RecordrollvmValue->Value(Ptro)->CodeGenFunctionrllvmValueloadRecord=loadElementstoreRecord::RecordrollvmValue->llvmValue->Value(Ptro)->CodeGenFunctionr()storeRecordmyptr=storeElementmptrydecomposeRecord::RecordrollvmValue->Valueo->CodeGenFunctionrllvmValuedecomposeRecordm=extractElementmcomposeRecord::(IsTypeo)=>RecordrollvmValue->llvmValue->CodeGenFunctionr(Valueo)composeRecordmv=insertElementmv(LLVM.valueLLVM.undef)pair::(Calas,Cblbs,IsSizedassas,IsSizedbssbs)=>Recordr(Struct(as,(bs,())))(al,bl)pair=liftA2(,)(elementfstd0)(elementsndd1)instance(Calas,Cblbs,IsSizedassas,IsSizedbssbs)=>C(al,bl)(Struct(as,(bs,())))whereload=loadRecordpairstore=storeRecordpairdecompose=decomposeRecordpaircompose=composeRecordpairtriple::(Calas,Cblbs,Cclcs,IsSizedassas,IsSizedbssbs,IsSizedcsscs)=>Recordr(Struct(as,(bs,(cs,()))))(al,bl,cl)triple=liftA3(,,)(elementfst3d0)(elementsnd3d1)(elementthd3d2)instance(Calas,Cblbs,Cclcs,IsSizedassas,IsSizedbssbs,IsSizedcsscs)=>C(al,bl,cl)(Struct(as,(bs,(cs,()))))whereload=loadRecordtriplestore=storeRecordtripledecompose=decomposeRecordtriplecompose=composeRecordtriple{-
This would not work for Booleans,
since on x86 LLVM's @i1@ type uses one byte in memory,
whereas Storable uses 4 byte and 4 byte alignment.
instance (LLVM.IsFirstClass a) => C (Value a) a where
load = LLVM.load
store = LLVM.store
decompose = return
compose = return
-}class(LLVM.IsFirstClassllvmType,IsTypellvmStruct)=>FirstClassllvmTypellvmStruct|llvmType->llvmStructwherefromStorable::ValuellvmStruct->CodeGenFunctionr(ValuellvmType)toStorable::ValuellvmType->CodeGenFunctionr(ValuellvmStruct)instanceFirstClassFloatFloatwherefromStorable=return;toStorable=returninstanceFirstClassDoubleDoublewherefromStorable=return;toStorable=returninstanceFirstClassInt8Int8wherefromStorable=return;toStorable=returninstanceFirstClassInt16Int16wherefromStorable=return;toStorable=returninstanceFirstClassInt32Int32wherefromStorable=return;toStorable=returninstanceFirstClassInt64Int64wherefromStorable=return;toStorable=returninstanceFirstClassWord8Word8wherefromStorable=return;toStorable=returninstanceFirstClassWord16Word16wherefromStorable=return;toStorable=returninstanceFirstClassWord32Word32wherefromStorable=return;toStorable=returninstanceFirstClassWord64Word64wherefromStorable=return;toStorable=returninstanceFirstClassBoolWord32wherefromStorable=A.cmpLLVM.CmpNE(LLVM.valueLLVM.zero)toStorable=LLVM.zextinstance(LLVM.Posn,LLVM.IsPrimitivea,LLVM.IsPrimitiveam,FirstClassaam)=>FirstClass(LLVM.Vectorna)(LLVM.Vectornam)wherefromStorable=Vector.mapfromStorabletoStorable=Vector.maptoStorableinstance(LLVM.Natn,LLVM.IsFirstClassam,FirstClassaam,IsSizedaasize,IsSizedamamsize)=>FirstClass(LLVM.Arrayna)(LLVM.Arraynam)wherefromStorable=Array.mapfromStorabletoStorable=Array.maptoStorableinstance(IsTypea)=>FirstClass(Ptra)(Ptra)wherefromStorable=return;toStorable=returninstanceFirstClass(StablePtra)(StablePtra)wherefromStorable=return;toStorable=returninstance(LLVM.IsFirstClass(Structs),IsType(Structsm),ConvertStructssmTypeNum.D0ssm)=>FirstClass(Structs)(Structsm)wherefromStorablesm=caseundefinedofsfields->dos<-decomposeFieldsfields(fieldssm)d0smlet_=asTypeOf(fieldss)sfieldsreturnstoStorables=caseundefinedofsmfields->dosm<-composeField(fieldss)smfieldsd0slet_=asTypeOf(fieldssm)smfieldsreturnsmfields::Value(Structs)->sfields_=undefinedclassConvertStructssmiremremm|s->sm,rem->remm,srem->i,smremm->iwheredecomposeField::rem->remm->i->Value(Structsm)->CodeGenFunctionr(Value(Structs))composeField::rem->remm->i->Value(Structs)->CodeGenFunctionr(Value(Structsm))instance(LLVM.GetValue(Structs)ia,LLVM.GetValue(Structsm)iam,FirstClassaam,ConvertStructssmi'remremm,TypeNum.Succii')=>ConvertStructssmi(a,rem)(am,remm)wheredecomposeField~(_,rem_)~(_,remm)ism=dos<-decomposeFieldrem_remm(TypeNum.succi)sma<-fromStorable=<<LLVM.extractvaluesmiLLVM.insertvaluesaicomposeField~(_,rem_)~(_,remm)is=dosm<-composeFieldrem_remm(TypeNum.succi)sam<-toStorable=<<LLVM.extractvaluesiLLVM.insertvaluesmamiinstance(IsType(Structs),IsType(Structsm))=>ConvertStructssmi()()wheredecomposeField____=return(LLVM.valueLLVM.undef)composeField____=return(LLVM.valueLLVM.undef)instance(FirstClassaam)=>C(Valuea)amwheredecompose=fromStorablecompose=toStorableinstanceC()(Struct())whereload_=return()store__=return()decompose_=return()compose_=return(LLVM.valueLLVM.undef)castStorablePtr::(MakeValueTuplehaskellValuellvmValue,CllvmValuellvmStruct)=>PtrhaskellValue->PtrllvmStructcastStorablePtr=castPtrloadNewtype::(Cao)=>(a->llvmValue)->Value(Ptro)->CodeGenFunctionrllvmValueloadNewtypewrapptr=fmapwrap$loadptrstoreNewtype::(Cao)=>(llvmValue->a)->llvmValue->Value(Ptro)->CodeGenFunctionr()storeNewtypeunwrapyptr=store(unwrapy)ptrdecomposeNewtype::(Cao)=>(a->llvmValue)->Valueo->CodeGenFunctionrllvmValuedecomposeNewtypewrapy=fmapwrap$decomposeycomposeNewtype::(Cao)=>(llvmValue->a)->llvmValue->CodeGenFunctionr(Valueo)composeNewtypeunwrapy=compose(unwrapy)