Literal.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 UndecidableInstances #-}

module Feldspar.Compiler.Imperative.FromCore.Literal where



import Control.Monad.RWS
import Data.Complex
import GHC.Float (float2Double)

import Language.Syntactic

import Feldspar.Core.Types
import Feldspar.Core.Interpretation
import Feldspar.Core.Constructs.Literal

import Feldspar.Range (upperBound)

import Feldspar.Compiler.Imperative.Frontend
import Feldspar.Compiler.Imperative.FromCore.Interpretation

instance Compile (Literal TypeCtx) dom
  where
    compileExprSym (Literal a) info Nil = literal (infoType info) (infoSize info) a

    compileProgSym (Literal a) info loc Nil = literalLoc loc (infoType info) (infoSize info) a

literal :: TypeRep a -> Size a -> a -> CodeWriter Expr
literal UnitType _          ()     = return $ LitI I32 0
literal BoolType _          a      = return $ boolToExpr a
literal trep@(IntType _ _) sz a    = return $ LitI (compileTypeRep trep sz) (toInteger a)
literal FloatType _         a      = return $ LitF $ float2Double a
literal (ComplexType t) sz  (r:+i) = do re <- literal t (defaultSize t) r
                                        ie <- literal t (defaultSize t) i
                                        return $ LitC re ie
literal t s a = do loc <- freshVar "x" t s
                   withDecl loc $ literalLoc loc t s a
                   return loc

literalLoc :: Location -> TypeRep a -> Size a -> a -> CodeWriter ()
literalLoc loc ty@(ArrayType t) (rs :> es) e
    = do
        tellProg [setLength loc $ LitI I32 $ toInteger $ upperBound rs]
        zipWithM_ (writeElement loc t es) (map (LitI I32) [0..]) e
  where writeElement :: Expr -> TypeRep a -> Size a -> Expr -> a -> CodeWriter ()
        writeElement loc ty sz ix e = do expr <- literal ty sz e
                                         tellProg [loc :!: ix := expr]
literalLoc loc t@(Tup2Type ta tb) (sa,sb) (a,b) =
    do aExpr <- literal ta sa a
       bExpr <- literal tb sb b
       tellProg [loc :.: "member1" := aExpr
                ,loc :.: "member2" := bExpr]
literalLoc loc t@(Tup3Type ta tb tc) (sa,sb,sc) (a,b,c) =
    do aExpr <- literal ta sa a
       bExpr <- literal tb sb b
       cExpr <- literal tc sc c
       tellProg [loc :.: "member1" := aExpr
                ,loc :.: "member2" := bExpr
                ,loc :.: "member3" := cExpr]
literalLoc loc t@(Tup4Type ta tb tc td) (sa,sb,sc,sd) (a,b,c,d) =
    do aExpr <- literal ta sa a
       bExpr <- literal tb sb b
       cExpr <- literal tc sc c
       dExpr <- literal td sd d
       tellProg [loc :.: "member1" := aExpr
                ,loc :.: "member2" := bExpr
                ,loc :.: "member3" := cExpr
                ,loc :.: "member4" := dExpr]
literalLoc loc t@(Tup5Type ta tb tc td te) (sa,sb,sc,sd,se) (a,b,c,d,e) =
    do aExpr <- literal ta sa a
       bExpr <- literal tb sb b
       cExpr <- literal tc sc c
       dExpr <- literal td sd d
       eExpr <- literal te se e
       tellProg [loc :.: "member1" := aExpr
                ,loc :.: "member2" := bExpr
                ,loc :.: "member3" := cExpr
                ,loc :.: "member4" := dExpr
                ,loc :.: "member5" := eExpr]
literalLoc loc t@(Tup6Type ta tb tc td te tf) (sa,sb,sc,sd,se,sf) (a,b,c,d,e,f) =
    do aExpr <- literal ta sa a
       bExpr <- literal tb sb b
       cExpr <- literal tc sc c
       dExpr <- literal td sd d
       eExpr <- literal te se e
       fExpr <- literal tf sf f
       tellProg [loc :.: "member1" := aExpr
                ,loc :.: "member2" := bExpr
                ,loc :.: "member3" := cExpr
                ,loc :.: "member4" := dExpr
                ,loc :.: "member5" := eExpr
                ,loc :.: "member5" := fExpr]
literalLoc loc t@(Tup7Type ta tb tc td te tf tg) (sa,sb,sc,sd,se,sf,sg) (a,b,c,d,e,f,g) =
    do aExpr <- literal ta sa a
       bExpr <- literal tb sb b
       cExpr <- literal tc sc c
       dExpr <- literal td sd d
       eExpr <- literal te se e
       fExpr <- literal tf sf f
       gExpr <- literal tg sg g
       tellProg [loc :.: "member1" := aExpr
                ,loc :.: "member2" := bExpr
                ,loc :.: "member3" := cExpr
                ,loc :.: "member4" := dExpr
                ,loc :.: "member5" := eExpr
                ,loc :.: "member5" := fExpr
                ,loc :.: "member5" := gExpr]
literalLoc loc t sz a = do rhs <- literal t sz a
                           tellProg [loc := rhs]