Codes.hs

{- |
Module      :  $Header$
Description :  Mapping of CAO syntax to operation codes.
Copyright   :  (c) SMART Team / HASLab
License     :  GPL

Maintainer  :  Paulo Silva <paufil@di.uminho.pt>
Stability   :  experimental
Portability :  non-portable

-}

module Language.CAO.Syntax.Codes where

import Language.CAO.Platform.Naming
import Language.CAO.Common.SrcLoc

import Language.CAO.Syntax

instance Codes a => Codes (Located a) where
    codeOf (L _ e) = codeOf e

instance Codes a => Codes (TExpr a) where
    codeOf (TyE _ e) = codeOf e

instance Codes (Expr a) where
    codeOf = opCode

-- Operation names --
opCode :: Expr a -> OpCode
opCode (Lit _)         = code_init
opCode (StructProj _ _)  = code_select
opCode (UnaryOp op _)    = codeOf op
opCode (BinaryOp op _ _) = codeOf op
opCode (Access _ op)   = codeOf op
opCode _ =
    error $ "<CaoToC.h>.<opCode> - Not implemented translation"

instance Codes UOp where
    codeOf = uopCode

uopCode :: UOp -> OpCode
uopCode op = 
    case op of
        Sym    -> code_sym
        Not    -> code_not
        BNot   -> code_not

instance Codes (BinOp id) where
    codeOf = bopCode

bopCode :: BinOp id -> OpCode
bopCode (ArithOp op) = 
    case op of
        Plus   -> code_add
        Minus  -> code_sub
        Times  -> code_mul
        Power  -> code_pow
        Div    -> code_div
        ModOp  -> code_mod
bopCode (BoolOp op)   =  
    case op of
        Or     -> code_or
        And    -> code_and
        Xor    -> code_xor
bopCode (BitOp op)    = 
    case op of
        BWOr   -> code_or
        BWAnd  -> code_and
        BWXor  -> code_xor
bopCode (BitsSROp op) = 
    case op of
        SUp    -> code_shift_up
        SDown  -> code_shift_down
        RUp    -> code_rot_up
        RDown  -> code_rot_down
bopCode (CmpOp _ op)    = 
    case op of
        Eq     -> code_equal
        Neq    -> code_nequal
        Leq    -> code_lte
        Lt     -> code_lt
        Gt     -> code_gt
        Geq    -> code_gte
bopCode Concat        = code_concat

instance Codes (APat id) where
    codeOf = apatCode

apatCode :: APat id -> OpCode
apatCode pat = 
    case pat of
        VectP (CElem _)                 -> code_select
        VectP (CRange _ _)              -> code_range_select
        MatP  (CElem _)    (CElem _)    -> code_select
        MatP  (CRange _ _) (CRange _ _) -> code_range_select
        MatP  (CRange _ _) (CElem _)    -> code_row_range_select
        MatP  (CElem _)    (CRange _ _) -> code_col_range_select