{- - 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 TypeFamilies #-} module Feldspar.Compiler.Plugins.HandlePrimitives ( HandlePrimitives(..) , makeAssignment , makePrimitive, ) where import Feldspar.Compiler.Imperative.Representation import Feldspar.Compiler.Imperative.Semantics (SemanticInfo) import Feldspar.Compiler.Imperative.CodeGeneration (simpleType, typeof, listprint, compToC, toLeftValue) import Feldspar.Compiler.PluginArchitecture (TransformationPhase(..), Plugin(..), InfosFromPrimitiveParts(..)) import Feldspar.Compiler.Options import Feldspar.Compiler.Error handlePrimitivesError = handleError "PluginArch/HandlePrimitives" InternalError data HandlePrimitives = HandlePrimitives instance TransformationPhase HandlePrimitives where type From HandlePrimitives = () type To HandlePrimitives = () type Downwards HandlePrimitives = Int type Upwards HandlePrimitives = () transformPrimitive = transformPrimitive' instance Plugin HandlePrimitives where type ExternalInfo HandlePrimitives = (Int,DebugOption) executePlugin _ (_,NoPrimitiveInstructionHandling) procedure = procedure executePlugin _ (defArrSize,_) procedure = fst $ executeTransformationPhase HandlePrimitives defArrSize procedure transformPrimitive' :: HandlePrimitives -> Int -> Primitive () -> InfosFromPrimitiveParts HandlePrimitives -> ProgramConstruction () transformPrimitive' _ defArrSize old modified' = case (nameS,as) of ("(==)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "equal" "==" ("(/=)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "not_equal" "!=" ("(<)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "less" "<" ("(>)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "greater" ">" ("(<=)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "less_equal" "<=" ("(>=)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "greater_equal" ">=" ("not", [InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive PrefixOp 1 as "not" "!" ("(&&)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "and" "&&" ("(||)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "or" "||" ("div", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "divide" "/" ("rem", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "remainder" "%" ("mod", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 2 as "mod" "" ("(^)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 2 as "pow" "" ("(.&.)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "bit_and" "&" ("(.|.)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "bit_or" "|" ("xor", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "bit_xor" "^" ("complement", [InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive PrefixOp 1 as "bit_not" "~" ("bit", [InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 1 as "bit" "" ("setBit", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 2 as "setBit" "" ("clearBit", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 2 as "clearBit" "" ("complementBit", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 2 as "complementBit" "" ("testBit", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 2 as "testBit" "" ("shiftL", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "shiftL" "<<" ("shiftR", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "shiftR" ">>" ("rotateL", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 2 as "rotateL" "" ("rotateR", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 2 as "rotateR" "" -- ("shift", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 2 as "bit_shift" "" -- ("rotate", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 2 as "bit_rotate" "" ("bitSize", [InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 1 as "bitSize" "" ("isSigned", [InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 1 as "isSigned" "" ("abs", [InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 1 as "abs" "" ("signum", [InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 1 as "signum" "" ("(+)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "add" "+" ("(-)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "sub" "-" ("(*)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "mult" "*" ("(/)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "divide" "/" ("(!)", [arr@(InputActualParameter _), idx@(InputActualParameter _), out@(OutputActualParameter _)]) -> mkPrg $ makeAssignment (LeftValueExpression $ LeftValueInExpression (ArrayElemReferenceLeftValue $ ArrayElemReference (ArrayElemReferenceData (toLeftValue $ aToE arr) $ aToE idx) () ) () ) (aToL out) defArrSize ("setIx", [original@(InputActualParameter _), idx@(InputActualParameter _), val@(InputActualParameter _), result@(OutputActualParameter _)]) -> SequenceProgram $ Sequence [ Program (PrimitiveProgram $ Primitive (makeAssignment (aToE original) (aToL result) defArrSize) ()) () , Program (PrimitiveProgram $ Primitive (makeAssignment (aToE val) (ArrayElemReferenceLeftValue $ ArrayElemReference (ArrayElemReferenceData (aToL result) $ aToE idx) ()) defArrSize ) ()) () ] () ("copy", [in1@(InputActualParameter _), out@(OutputActualParameter _)]) -> mkPrg $ makeAssignment (aToE in1) (aToL out) defArrSize _ -> mkPrg $ modified where nameS = nameOfProcedureToCall $ procedureCallData $ (\(ProcedureCallInstruction x) -> x) $ primitiveInstruction old as = actualParametersOfProcedureToCall $ procedureCallData $ (\(ProcedureCallInstruction x) -> x) modified modified = recursivelyTransformedPrimitiveInstruction modified' mkPrg x = PrimitiveProgram (Primitive x ()) makeAssignment :: Expression () -> LeftValue () -> Int -> Instruction () makeAssignment in1 out defaultArraySize | simpleType (typeof in1) = AssignmentInstruction $ Assignment (AssignmentData out in1) () | otherwise = case (typeof in1) of (ImpArrayType _ t) -> makePrimitive SimpleFun 2 [eToA in1, eToA $ arraySize (typeof in1) defaultArraySize, lToA out] "copy" "" _ -> handlePrimitivesError $ "Unknown type in makeAssignment:\n" ++ show (typeof in1) makePrimitive :: FunctionRole -> Int -> [ActualParameter ()] -> String -> String -> Instruction () makePrimitive primType parNum as cFunName cOpName | simpleType (typeof out) = AssignmentInstruction $ Assignment (AssignmentData out (FunctionCallExpression funCall)) () | otherwise = ProcedureCallInstruction procCall where funCall = case (primType, parNum) of (SimpleFun, 1) -> FunctionCall (FunctionCallData SimpleFun (typeof out) completeFunName [in1]) () (SimpleFun, 2) -> FunctionCall (FunctionCallData SimpleFun (typeof out) completeFunName [in1, in2]) () (PrefixOp, 1) -> FunctionCall (FunctionCallData PrefixOp (typeof out) cOpName [in1]) () (InfixOp, 2) -> FunctionCall (FunctionCallData InfixOp (typeof out) cOpName [in1, in2]) () _ -> handlePrimitivesError $ "Invalid arguments:\n" ++ show (primType, parNum) procCall = case (primType, parNum) of (SimpleFun, 1) -> ProcedureCall (ProcedureCallData completeProcName [in1', out']) () (SimpleFun, 2) -> ProcedureCall (ProcedureCallData completeProcName [in1', in2', out']) () (PrefixOp, 1) -> ProcedureCall (ProcedureCallData completeProcName [in1', out']) () (InfixOp, 2) -> ProcedureCall (ProcedureCallData completeProcName [in1', in2', out']) () _ -> handlePrimitivesError $ "Invalid arguments:\n" ++ show (primType, parNum) completeFunName = cFunName ++ "_fun_" ++ toFunName (typeof in1) completeProcName = cFunName ++ "_" ++ toFunName (typeof in1) (in1,in1') = case (filter isInparam as) of x:_ -> (aToE x,x) _ -> handlePrimitivesError $ "There is not any Input parameter:\n" ++ show as (in2,in2') = case (filter isInparam as) of _:x:_ -> (aToE x,x) _ -> handlePrimitivesError $ "There is not enough Input parameter:\n" ++ show as (out,out') = case (filter (not . isInparam) as) of x:_ -> (aToL x,x) _ -> handlePrimitivesError $ "There is not any Output parameter:\n" ++ show as toFunName :: Type -> String toFunName BoolType = "bool" toFunName FloatType = "float" toFunName (Numeric sig siz) = listprint id "_" [compToC sig, compToC siz] toFunName (ImpArrayType _ t@(ImpArrayType _ _)) = toFunName t toFunName (ImpArrayType _ t) = "arrayOf_" ++ toFunName t arraySize :: Type -> Int -> Expression () arraySize a@(ImpArrayType _ t) defaultArraySize = ConstantExpression $ IntConstant $ IntConstantType (arraySize' a) () where arraySize' (ImpArrayType (Norm n) t) = n * arraySize' t arraySize' (ImpArrayType (Defined n) t) = n * arraySize' t arraySize' (ImpArrayType Undefined t) = defaultArraySize * arraySize' t arraySize' _ = 1 isInparam (InputActualParameter _) = True isInparam (OutputActualParameter _) = False aToE (InputActualParameter x) = inputActualParameterExpression x aToL (OutputActualParameter x) = outputActualParameterLeftValue x -- TODO create a simple wrapper interface based on these functions eToA x = InputActualParameter $ InputActualParameterType x () lToA x = OutputActualParameter $ OutputActualParameterType x ()