feldspar-compiler-0.2: Feldspar/Compiler/Plugins/HandlePrimitives.hs

{-# 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 ()