Frontend.hs

--
-- Copyright (c) 2009-2011, 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 ViewPatterns #-}

module Feldspar.Compiler.Imperative.Frontend where

import Data.List

import Feldspar.Compiler.Imperative.Representation hiding (Type, UserType, Cast, In, Out, Variable, Block, Pointer, Comment)
import qualified Feldspar.Compiler.Imperative.Representation as AIR

import Feldspar.Core.Types hiding (Type)

-- * Frontend data types

data Mod = Mod [Ent]
  deriving (Show)

data Ent
    = StructD String [(String, Type)]
    | ProcDf String [Var] [Var] Prog
    | ProcDcl String [Var] [Var]
  deriving (Show)

data Type
    = Void
    | Boolean
    | Bit
    | Floating
    | I8 | I16 | I32 | I40 | I64
    | U8 | U16 | U32 | U40 | U64
    | Complex Type
    | UserType String
    | Array Type
    | SizedArray Int Type
    | Struct [(String, Type)]
  deriving Eq

data Expr
    = Var Type String
    | Ptr Type String
    | Tr
    | Fl
    | LitI Type Integer
    | LitF Double
    | LitC Expr Expr
    | Expr :!: Expr
    | Expr :.: String
    | Binop Type String [Expr]
    | Fun Type String [Expr]
    | Cast Type Expr
    | SizeofE Expr
    | SizeofT Type
  deriving (Show)

data Prog
    = Skip
    | BComment String
    | Comment String
    | Expr := Expr
    | Call String [Param]
    | Seq [Prog]
    | If Expr Prog Prog
    | While Prog Expr Prog
    | For String Expr Int Prog
    | Block [Def] Prog
  deriving (Show)

data Param
    = In Expr
    | Out Expr
  deriving (Show)

data Block
    = Bl [Def] Prog
  deriving (Show)

data Def
    = Init Type String Expr
    | Def Type String
  deriving (Show)

data Var
    = Variable Type String
    | Pointer Type String
  deriving (Show)

-- * Conversion between representation and frontend

class Interface t where
    type Repr t
    toInterface :: Repr t -> t
    fromInterface :: t -> Repr t

instance Interface Mod where
    type Repr Mod = AIR.Module ()
    toInterface (Module entities ()) = Mod $ map toInterface entities
    fromInterface (Mod entities) = AIR.Module (map fromInterface entities) ()

instance Interface Ent where
    type Repr Ent = AIR.Entity ()
    toInterface (AIR.StructDef name members () ()) =
        StructD name (map (\(StructMember mname mtyp ())->(mname,toInterface mtyp)) members)
    toInterface (AIR.ProcDef name inparams outparams body () ()) =
        ProcDf name (map toInterface inparams) (map toInterface outparams) (toProg body)
    toInterface (AIR.ProcDecl name inparams outparams () ()) =
        ProcDcl name (map toInterface inparams) (map toInterface outparams)
    fromInterface (StructD name members) =
        AIR.StructDef name (map (\(mname,mtyp)->(StructMember mname (fromInterface mtyp) ())) members) () ()
    fromInterface (ProcDf name inparams outparams body) =
        AIR.ProcDef name (map fromInterface inparams) (map fromInterface outparams) (toBlock body) () ()
    fromInterface (ProcDcl name inparams outparams) =
        AIR.ProcDecl name (map fromInterface inparams) (map fromInterface outparams) () ()


instance Interface Type where
    type Repr Type = AIR.Type
    toInterface VoidType = Void
    toInterface AIR.BoolType = Boolean
    toInterface BitType = Bit
    toInterface AIR.FloatType = Floating
    toInterface (NumType Signed S8) = I8
    toInterface (NumType Signed S16) = I16
    toInterface (NumType Signed S32) = I32
    toInterface (NumType Signed S40) = I40
    toInterface (NumType Signed S64) = I64
    toInterface (NumType Unsigned S8) = U8
    toInterface (NumType Unsigned S16) = U16
    toInterface (NumType Unsigned S32) = U32
    toInterface (NumType Unsigned S40) = U40
    toInterface (NumType Unsigned S64) = U64
    toInterface (AIR.ComplexType t) = Complex $ toInterface t
    toInterface (AIR.UserType s) = UserType s
    toInterface (AIR.ArrayType (LiteralLen l) t) = SizedArray l $ toInterface t
    toInterface (AIR.ArrayType _ t) = Array $ toInterface t
    toInterface (AIR.StructType fields) = Struct $ map (\(name,t) -> (name,toInterface t)) fields
    fromInterface Void = VoidType
    fromInterface Boolean = AIR.BoolType
    fromInterface Bit = BitType
    fromInterface Floating = AIR.FloatType
    fromInterface I8 = NumType Signed S8
    fromInterface I16 = NumType Signed S16
    fromInterface I32 = NumType Signed S32
    fromInterface I40 = NumType Signed S40
    fromInterface I64 = NumType Signed S64
    fromInterface U8 = NumType Unsigned S8
    fromInterface U16 = NumType Unsigned S16
    fromInterface U32 = NumType Unsigned S32
    fromInterface U40 = NumType Unsigned S40
    fromInterface U64 = NumType Unsigned S64
    fromInterface (Complex t) = AIR.ComplexType $ fromInterface t
    fromInterface (UserType s) = AIR.UserType s
    fromInterface (Array t) = AIR.ArrayType UndefinedLen $ fromInterface t
    fromInterface (SizedArray l t) = AIR.ArrayType (LiteralLen l) $ fromInterface t
    fromInterface (Struct fields) = AIR.StructType $ map (\(name,t) -> (name,fromInterface t)) fields

instance Interface Expr where
    type Repr Expr = Expression ()
    toInterface (VarExpr (AIR.Variable name t Value ()) ()) = Var (toInterface t) name
    toInterface (VarExpr (AIR.Variable name t AIR.Pointer ()) ()) = Ptr (toInterface t) name
    toInterface (ArrayElem arr idx () ()) = (toInterface arr) :!: (toInterface idx)
    toInterface (StructField str field () ()) = (toInterface str) :.: field
    toInterface (ConstExpr (BoolConst True () ()) ()) = Tr
    toInterface (ConstExpr (BoolConst False () ()) ()) = Fl
    toInterface (ConstExpr (IntConst x t () ()) ()) = LitI (toInterface t) x
    toInterface (ConstExpr (FloatConst x () ()) ()) = LitF x
    toInterface (ConstExpr (ComplexConst r i () ()) ()) = LitC (toInterface $ ConstExpr r ()) (toInterface $ ConstExpr i ())
    toInterface (FunctionCall (Function name t Prefix) ps () ()) = Fun (toInterface t) name $ map toInterface ps
    toInterface (FunctionCall (Function name t Infix) ps () ()) = Binop (toInterface t) name $ map toInterface ps
    toInterface (AIR.Cast t e () ()) = Cast (toInterface t) (toInterface e)
    toInterface (SizeOf (Left t) () ()) = SizeofT $ toInterface t
    toInterface (SizeOf (Right e) () ()) = SizeofE $ toInterface e
    fromInterface (Var t name) = VarExpr (AIR.Variable name (fromInterface t) Value ()) ()
    fromInterface (Ptr t name) = VarExpr (AIR.Variable name (fromInterface t) AIR.Pointer ()) ()
    fromInterface (Tr) = ConstExpr (BoolConst True () ()) ()
    fromInterface (Fl) = ConstExpr (BoolConst False () ()) ()
    fromInterface (LitI t x) = ConstExpr (IntConst x (fromInterface t) () ()) ()
    fromInterface (LitF x) = ConstExpr (FloatConst x () ()) ()
    fromInterface (LitC (fromInterface -> (ConstExpr r ())) (fromInterface -> (ConstExpr i ()))) =
        ConstExpr (ComplexConst r i () ()) ()
    fromInterface (LitC _ _) = error "Illegal LitC" -- TODO (?)
    fromInterface (Binop t name es) = FunctionCall (Function name (fromInterface t) Infix) (map fromInterface es) () ()
    fromInterface (Fun t name es) = FunctionCall (Function name (fromInterface t) Prefix) (map fromInterface es) () ()
    fromInterface (Cast t e) = AIR.Cast (fromInterface t) (fromInterface e) () ()
    fromInterface (SizeofE e) = SizeOf (Right $ fromInterface e) () ()
    fromInterface (SizeofT t) = SizeOf (Left $ fromInterface t) () ()
    fromInterface (arr :!: idx) = ArrayElem (fromInterface arr) (fromInterface idx) () ()
    fromInterface (str :.: field) = StructField (fromInterface str) field () ()

instance Interface Prog where
    type Repr Prog = AIR.Program ()
    toInterface (Empty () ()) = Skip
    toInterface (AIR.Comment True s () ()) = BComment s
    toInterface (AIR.Comment False s () ()) = Comment s
    toInterface (Assign lhs rhs () ()) = (toInterface lhs) := (toInterface rhs)
    toInterface (ProcedureCall s ps () ()) = Call s (map toInterface ps)
    toInterface (Sequence ps () ()) = Seq (map toInterface ps)
    toInterface (Branch e b1 b2 () ()) = If (toInterface e) (toProg b1) (toProg b2)
    toInterface (SeqLoop e pe b () ()) = While (toProg pe) (toInterface e) (toProg b)
    toInterface (ParLoop v e i b () ()) = For (varName v) (toInterface e) i (toProg b)
    toInterface (BlockProgram b ()) = Block (map toInterface $ locals b) (toInterface $ blockBody b)
    fromInterface (Skip) = Empty () ()
    fromInterface (BComment s) = AIR.Comment True s () ()
    fromInterface (Comment s) = AIR.Comment False s () ()
    fromInterface (lhs := rhs) = Assign (fromInterface lhs) (fromInterface rhs) () ()
    fromInterface (Call s ps) = ProcedureCall s (map fromInterface ps) () ()
    fromInterface (Seq ps) = Sequence (map fromInterface ps) () ()
    fromInterface (If e p1 p2) = Branch (fromInterface e) (toBlock p1) (toBlock p2) () ()
    fromInterface (While pe e p) = SeqLoop (fromInterface e) (toBlock pe) (toBlock p) () ()
    fromInterface (For s e i p) = ParLoop
        (AIR.Variable s (NumType Unsigned S32) Value ()) (fromInterface e) i (toBlock p) () ()
    fromInterface (Block ds p) = BlockProgram (AIR.Block (map fromInterface ds) (fromInterface p) ()) ()

instance Interface Param where
    type Repr Param = ActualParameter ()
    toInterface (AIR.In e ()) = In (toInterface e)
    toInterface (AIR.Out e ()) = Out (toInterface e)
    fromInterface (In e) = AIR.In (fromInterface e) ()
    fromInterface (Out e) = AIR.Out (fromInterface e) ()

instance Interface Def where
    type Repr Def = Declaration ()
    toInterface (Declaration v (Just e) ()) = Init (toInterface $ varType v) (varName v) (toInterface e)
    toInterface (Declaration v Nothing ()) = Def (toInterface $ varType v) (varName v)
    fromInterface (Init t s e) = Declaration (AIR.Variable s (fromInterface t) Value ()) (Just $ fromInterface e) ()
    fromInterface (Def t s) = Declaration (AIR.Variable s (fromInterface t) Value ()) Nothing ()

instance Interface Block where
    type Repr Block = AIR.Block ()
    toInterface (AIR.Block ds p ()) = Bl (map toInterface ds) (toInterface p)
    fromInterface (Bl ds p) = AIR.Block (map fromInterface ds) (fromInterface p) ()

instance Interface Var where
    type Repr Var = AIR.Variable ()
    toInterface (AIR.Variable name typ Value ()) = Variable (toInterface typ) name
    toInterface (AIR.Variable name typ AIR.Pointer ()) = Pointer (toInterface typ) name
    fromInterface (Variable typ name) = AIR.Variable name (fromInterface typ) Value ()
    fromInterface (Pointer typ name) = AIR.Variable name (fromInterface typ) AIR.Pointer ()

toBlock :: Prog -> AIR.Block ()
toBlock (Block ds p) = AIR.Block (map fromInterface ds) (fromInterface p) ()
toBlock p = AIR.Block [] (fromInterface p) ()

toProg :: AIR.Block () -> Prog
toProg (AIR.Block [] p ()) = toInterface p
toProg (AIR.Block ds p ()) = Block (map toInterface ds) (toInterface p)

boolToExpr :: Bool -> Expr
boolToExpr True = Tr
boolToExpr False = Fl

setLength :: Expr -> Expr -> Prog
setLength arr len = Call "setLength" [Out arr, In len]

increaseLength :: Expr -> Expr -> Prog
increaseLength arr len = Call "increaseLength" [Out arr, In len]

copyProg :: Expr -> Expr -> Prog
copyProg outExp inExp = Call "copy" [Out outExp, In inExp]

copyProgPos :: Expr -> Expr -> Expr -> Prog
copyProgPos outExp shift inExp = Call "copyArrayPos" [Out outExp, In shift, In inExp]

copyProgLen :: Expr -> Expr -> Expr -> Prog
copyProgLen outExp inExp len = Call "copyArrayLen" [Out outExp, In inExp, In len]

instance Show Type
  where
    show Void       = "void"
    show Boolean    = "bool"
    show Bit        = "bit"
    show Floating   = "float"
    show I8         = "int8"
    show I16        = "int16"
    show I32        = "int32"
    show I40        = "int40"
    show I64        = "int64"
    show U8         = "uint8"
    show U16        = "uint16"
    show U32        = "uint32"
    show U40        = "uint40"
    show U64        = "uint64"
    show (Complex t)    = "complexOf_" ++ show t
    show (UserType s)   = "userType_" ++ s
    show (Array t)      = "arrayOf_" ++ show t
    show (SizedArray i t)   = "arrayOfSize_" ++ show i ++ "_" ++ show t
    show (Struct fields)    = "struct_" ++ intercalate "_" (map (\(s,t) -> s ++ "_" ++ show t) fields)

instance HasType Expr
  where
    type TypeOf Expr = Type
    typeof = toInterface . typeof . fromInterface

intWidth :: Type -> Maybe Integer
intWidth I8  = Just 8
intWidth I16 = Just 16
intWidth I32 = Just 32
intWidth I40 = Just 40
intWidth I64 = Just 64
intWidth U8  = Just 8
intWidth U16 = Just 16
intWidth U32 = Just 32
intWidth U40 = Just 40
intWidth U64 = Just 64
intWidth _   = Nothing

intSigned :: Type -> Maybe Bool
intSigned I8  = Just True
intSigned I16 = Just True
intSigned I32 = Just True
intSigned I40 = Just True
intSigned I64 = Just True
intSigned U8  = Just False
intSigned U16 = Just False
intSigned U32 = Just False
intSigned U40 = Just False
intSigned U64 = Just False
intSigned _   = Nothing

litB :: Bool -> Expr
litB True = Tr
litB False = Fl

isArray :: Type -> Bool
isArray (Array _) = True
isArray (SizedArray _ _) = True
isArray _ = False