---- Copyright (c) 2009-2010, 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 FlexibleInstances #-}moduleFeldspar.Compiler.Imperative.CodeGenerationwhereimportFeldspar.Compiler.Imperative.RepresentationimportFeldspar.Compiler.Imperative.SemanticsimportFeldspar.Compiler.ErrorimportFeldspar.Compiler.OptionsimportqualifiedData.ListasList(last,find)-------------------------- C code generation --------------------------codeGenerationError=handleError"CodeGeneration"dataPlace=Declaration_pl--value of var, need type, type array-style--declare variables|MainParameter_pl--value of var need type, type pointer-style--main fun parameters|ValueNeed_pl--value of var, not need type ---in Expressions|AddressNeed_pl--access of var, not need type ---output of fun|FunctionCallIn_pl--value of var, not need type - SPEC ARRAY FORMAT--input of fun deriving(Eq,Show)compToC::ToCa=>Platform->a->StringcompToCm=toCmDeclaration_plclassToCawheretoC::Platform->Place->a->StringinstanceToCTypewheretoCm_t=case(List.find(\(t',_,_)->t==t')$typesm)ofJust(_,s,_)->sNothing->codeGenerationErrorInternalError$"Unhandled type in platform "++namem--arraytype handled in variableinstanceToC(VariablePrettyPrintSemanticInfo)wheretoCmpa@(Variablertn_)=show_variablemprtnNoRestrictshow_variable::Platform->Place->VariableRole->Type->String->IsRestrict->Stringshow_variablemprtnrestr=listprint(id)" "[variableType,show_namerptn++arrLn]--concat [addSpace $ variableType, show_name r p t n, arrLn]where(variableType,arrLn)=show_typeptrestrshow_type::Place->Type->IsRestrict->(String,String)show_typeMainParameter_pl(ImpArrayTypest@(ImpArrayTypes2t2))restr=decl_matr_typest2s2restrshow_typeDeclaration_pl(ImpArrayTypest)restr=decl_arr_typets("","")show_typeMainParameter_pl(ImpArrayTypest)restr=decl_arr_type_0tsrestrshow_typeDeclaration_plt_=(toCmpt,"")show_typeMainParameter_plt_=(toCmpt,"")show_type___=("","")decl_arr_type_0::Type->Length->IsRestrict->(String,String)decl_arr_type_0tsRestrict=((toCmDeclaration_plt)++" * const restrict","")decl_arr_type_0ts_=((toCmDeclaration_plt)++" *","")decl_matr_type::Length->Type->Length->IsRestrict->(String,String)decl_matr_typembt2s2Restrict=decl_arr_typet2s2(" (* const restrict",")")decl_matr_typembt2s2_=decl_arr_typet2s2(" (*",")")decl_arr_type::Type->Length->(String,String)->(String,String)decl_arr_type(ImpArrayTypes2t2)mb(st1,st2)=decl_arr_typet2s2(st1,st2++(show_bracketsmb))decl_arr_typetmb(st1,st2)=((toCmDeclaration_plt)++st1,st2++show_bracketsmb)show_brackets::Length->Stringshow_bracketsUndefined=codeGenerationErrorInternalError$"Unattended unknown array size"show_brackets(Normi)=concat["[",showi,"]"]show_brackets(Definedi)=concat["[",showi,defaultArraySizeWarning,"]"]defaultArraySizeWarning::StringdefaultArraySizeWarning=" /* WARNING: Default size used!! */"show_name::VariableRole->Place->Type->String->Stringshow_name_FunctionCallIn_plt@(ImpArrayType__)n=concat["&(",n,genIndext,")"]show_name_AddressNeed_plt@(ImpArrayType__)n=concat["&(",n,genIndext,")"]show_name__(ImpArrayType__)n=nshow_nameValueplacetn|place==AddressNeed_pl="&"++n|otherwise=nshow_nameFunOutplacetn|place==AddressNeed_pl&&List.lastn==']'="&"++n|place==AddressNeed_pl&&List.lastn/=']'=n|place==Declaration_pl=codeGenerationErrorInternalError$"You can't declare output variable of the function"|place==MainParameter_pl="* "++n|List.lastn==']'=n|otherwise="(* "++n++")"genIndex::Type->StringgenIndex(ImpArrayType_t)="[0]"++genIndextgenIndex_=""instanceToC(ConstantPrettyPrintSemanticInfo)wheretoCmpc=toCmp$constantDatacinstanceToC(ConstantDataPrettyPrintSemanticInfo)wheretoCmpa@(ArrayConstantl)="{"++(toCArraympa)++"}"toCm_c=case(List.find(\(t',_)->t'==typeofc)$valuesm)ofJust(_,f)->fcNothing->casecof(IntConstanti)->show(intConstantValuei)(FloatConstanti)->show(floatConstantValuei)++"f"(BoolConstant(BoolConstantTypeTrue_))->"1"(BoolConstant(BoolConstantTypeFalse_))->"0"_->codeGenerationErrorInternalError$"Unhandled constant in platform "++namemtoCArray::Platform->Place->ConstantDataPrettyPrintSemanticInfo->StringtoCArraymp(ArrayConstantl)=listprint(toCArraymp)","(mapconstantData$arrayConstantValuel)toCArraympi=toCmpiinstanceToC(LeftValuePrettyPrintSemanticInfo)wheretoCmplv=toCmp$leftValueDatalvinstanceToC(LeftValueDataPrettyPrintSemanticInfo)wheretoCmp(VariableLeftValuev)=toCmpvtoCmp(ArrayElemReferenceLeftValueleftArrayElemReference)=toCmp$insertIndex(arrayNameleftArrayElemReference)whereinsertIndex::LeftValuePrettyPrintSemanticInfo->LeftValuePrettyPrintSemanticInfoinsertIndex(LeftValue(VariableLeftValuevariable)semInf)=LeftValue(VariableLeftValue$variable{variableType=decrArrayDepth(variableTypevariable),variableName=(concat[variableNamevariable,"[",toCmValueNeed_pl(arrayIndexleftArrayElemReference),"]"])})semInfinsertIndex(LeftValue(ArrayElemReferenceLeftValueleftArrayElemReference)semInf)=LeftValue(ArrayElemReferenceLeftValue$leftArrayElemReference{arrayName=(insertIndex(arrayNameleftArrayElemReference)),arrayIndex=(arrayIndexleftArrayElemReference)})semInfinstanceToC(ActualParameterPrettyPrintSemanticInfo)wheretoCmpap=toCmp$actualParameterDataapinstanceToC(ActualParameterDataPrettyPrintSemanticInfo)wheretoCmp(InputActualParametere)=toCmFunctionCallIn_pletoCmp(OutputActualParameterl)=toCmAddressNeed_pllinstanceToC(ExpressionPrettyPrintSemanticInfo)wheretoCmpexpr=toCmp(expressionDataexpr)instanceToC(ExpressionDataPrettyPrintSemanticInfo)wheretoCmp(LeftValueExpressionlv)=toCmplvtoCmp(ConstantExpressionc)=toCmpctoCmp(FunctionCallExpression(FunctionCallInfixOp_f[a,b]_))=concat["(",toCmpa," ",f," ",toCmpb,")"]toCmp(FunctionCallExpression(FunctionCall_tfx_))=concat[f,"(",listprint(toCmp)", "x,")"]instanceToC(ProcedurePrettyPrintSemanticInfo)wheretoCmp(ProcedurenilolprsemInf)=concat["void ",n,"(",param,")\n{\n",prog,"}\n"]whereparam=listprint(toCmMainParameter_pl)", "(il++ol)prog=ind(toCmDeclaration_pl)prinstanceToC(BlockPrettyPrintSemanticInfo)wheretoCmp(BlockdprsemInf)=listprintid"\n"[decl,toCmppr]wheredecl=concat$map(\a->toCmDeclaration_pla++";\n")dinstanceToC(FormalParameterPrettyPrintSemanticInfo)wheretoCmp(FormalParametervrestr)=(helperpvrestr)wherehelper::Place->VariablePrettyPrintSemanticInfo->IsRestrict->StringhelperMainParameter_pl(Variablertn_)restr=show_variablemMainParameter_plrtnrestrhelper_(Variablertn_)restr=show_variablemDeclaration_plrtnrestrinstanceToC(LocalDeclarationPrettyPrintSemanticInfo)wheretoCmp(LocalDeclarationviisDefArrSize)=(helperpvi)wherehelper::Place->VariablePrettyPrintSemanticInfo->(Maybe(ExpressionPrettyPrintSemanticInfo))->StringhelperMainParameter_plvi=concat[toCmMainParameter_plv,initi]helper_vi=concat[toCmDeclaration_plv,initi]init::Maybe(ExpressionPrettyPrintSemanticInfo)->StringinitNothing=""init(Juste)=" = "++toCmValueNeed_pleinstanceToC(InstructionPrettyPrintSemanticInfo)wheretoCmpinstruction=toCmp$instructionDatainstructioninstanceToC(InstructionDataPrettyPrintSemanticInfo)wheretoCmp(AssignmentInstructionassignment)=concat[toCmValueNeed_pl(assignmentLhsassignment)," = ",toCmValueNeed_pl(assignmentRhsassignment),";\n"]toCmp(ProcedureCallInstructionprocedureCall)=concat[nameOfProcedureToCallprocedureCall,"(",listprint(toCmp)", "(actualParametersOfProcedureToCallprocedureCall),");\n"]instanceToC(ProgramPrettyPrintSemanticInfo)wheretoCmp(Program(EmptyProgram(Emptyi))seminf)=""toCmp(Program(PrimitiveProgram(Primitiveiseminf))psi)=toCmpitoCmp(Program(SequenceProgram(Sequenceps_))psi)=listprint(toCmp)""pstoCmp(Program(BranchProgram(BranchcontPrgePrg_))psi)=concat["if(",toCmValueNeed_plcon,")\n{\n",ind(toCmp)tPrg,"}\nelse\n{\n",ind(toCmp)ePrg,"}\n"]toCmp(Program(SequentialLoopProgram(SequentialLoopcondVarcondCalcloopBody_))psi)=concat["{\n",indidwhereBody,"}\n"]wherewhereBody=concat[toCmpcondCalc,"while(",toCmValueNeed_plcondVar,")\n","{\n",ind(toCmp)loopBody,ind(toCmp)(blockInstructionscondCalc),"}\n"]toCmp(Program(ParallelLoopProgram(ParallelLoopvnumstepprg_))psi)=concat["{\n",indidfor_seq,"}\n"]wherefor_seq=concat[toCmDeclaration_plv,";\nfor(",for_init,for_test,for_inc,")\n{\n",ind(toCmp)prg,"}\n"]for_init=concat[toCmValueNeed_plv," = 0; "]for_test=concat[toCmValueNeed_plv," < ",toCmValueNeed_plnum,"; "]for_inc=concat[toCmValueNeed_plv," += ",showstep]instanceToCa=>ToC(Maybea)wheretoC_pNothing=""toCmp(Justa)=toCmpainstance(ToCa)=>ToC[a]wheretoCmpxs=listprint(toCmp)"\n"xs------------------------ Type ------------------------classHasTypeawheretypeof::a->Typeinstance(SemanticInfot)=>HasType(Variablet)wheretypeof(Variablerts_)=tinstance(SemanticInfot)=>HasType(LeftValuet)wheretypeoflv=typeof$leftValueDatalvinstance(SemanticInfot)=>HasType(LeftValueDatat)wheretypeof(VariableLeftValuev)=typeofvtypeof(ArrayElemReferenceLeftValuearrayElemReference)=decrArrayDepth(typeof(arrayNamearrayElemReference))instance(SemanticInfot)=>HasType(Constantt)wheretypeofc=typeof$constantDatacinstance(SemanticInfot)=>HasType(ConstantDatat)wheretypeof(IntConstant_)=NumericImpSignedS32typeof(FloatConstant_)=FloatTypetypeof(BoolConstant_)=BoolTypetypeofarr@(ArrayConstantl)=ImpArrayType(Norm$lengthinnerConstList)elemtypewhereelemtype=caseinnerConstListof[]->codeGenerationErrorInternalError$"Const array with 0 elements: "++showarr_->checktype(typeof$headinnerConstList)(maptypeofinnerConstList)innerConstList=arrayConstantValuelchecktype::Type->[Type]->Typechecktypet[]=tchecktypet(x:xs)|t==x=checktypetxs|otherwise=codeGenerationErrorInternalError$"Different element types in constant array: "++showarrinstance(SemanticInfot)=>HasType(Expressiont)wheretypeofe=typeof$expressionDataeinstance(SemanticInfot)=>HasType(ExpressionDatat)wheretypeof(LeftValueExpressionlve)=typeoflvetypeof(ConstantExpressionc)=typeofctypeof(FunctionCallExpressionfunctionCallExpression)=typeOfFunctionToCallfunctionCallExpressioninstance(SemanticInfot)=>HasType(ActualParametert)wheretypeofap=typeof$actualParameterDataapinstance(SemanticInfot)=>HasType(ActualParameterDatat)wheretypeof(InputActualParametere)=typeofetypeof(OutputActualParameterl)=typeofl------------------------ Helper functions ------------------------ind::(a->String)->a->Stringindfx=unlines$map(\a->" "++a)$lines$fxlistprint::(a->String)->String->[a]->Stringlistprintfsxs=listprint's$filter(\a->a/="")$mapfxswherelistprint'_[]=""listprint'_[x]=xlistprint's(x:y:xs)=x++s++listprint's(y:xs)parameterToExpression::(SemanticInfot)=>ActualParametert->ExpressiontparameterToExpression(ActualParameter(InputActualParametere)_)=eparameterToExpression(ActualParameter(OutputActualParameterlv)_)=Expression(LeftValueExpressionlv)undefined-- TODO undefineddecrArrayDepth::Type->TypedecrArrayDepth(ImpArrayType_t)=tdecrArrayDepth_=codeGenerationErrorInternalError$"A variable is indexed, but not array!"simpleType::Type->BoolsimpleTypeBoolType=TruesimpleType(Numeric__)=TruesimpleTypeFloatType=TruesimpleType(ImpArrayType__)=FalsesimpleType(UserType_)=TruetoLeftValue::(SemanticInfot)=>Expressiont->LeftValuettoLeftValue(Expression(LeftValueExpressionlv)_)=lvtoLeftValuee=codeGenerationErrorInternalError$showe++" is not a left value."contains::(SemanticInfot)=>String->Expressiont->Boolcontainsn(Expression(LeftValueExpressionlv)_)=contains'n(leftValueDatalv)wherecontains'n(VariableLeftValue(Variable__n'_))=n==n'contains'n(ArrayElemReferenceLeftValuearrayElemReference)=contains'n(leftValueData$arrayNamearrayElemReference)||containsn(arrayIndexarrayElemReference)contains_(Expression(ConstantExpression_)_)=Falsecontainsn(Expression(FunctionCallExpressionfunctionCallExpression)_)=any(containsn)(actualParametersOfFunctionToCallfunctionCallExpression)getVarName::(SemanticInfot)=>LeftValuet->StringgetVarName(LeftValue(VariableLeftValue(Variable__n_))_)=ngetVarName(LeftValue(ArrayElemReferenceLeftValuearrayElemReference)_)=getVarName(arrayNamearrayElemReference)