feldspar-compiler-0.5.0.1: Feldspar/Compiler/Backend/C/Plugin/Locator.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 TypeFamilies #-}
module Feldspar.Compiler.Backend.C.Plugin.Locator where
import Feldspar.Transformation
import Feldspar.Compiler.Backend.C.CodeGeneration
import Feldspar.Compiler.Backend.C.Plugin.PrettyPrint
import Feldspar.Compiler.Backend.C.Platforms
import Feldspar.Compiler.Backend.C.Options
import Feldspar.Compiler.Error
-- ===========================================================================
-- == GetPrg plugin
-- ===========================================================================
instance Default Bool where
def = False
instance Default (Program DebugToCSemanticInfo) where
def = Empty ((0,0),(0,0)) ((0,0),(0,0))
instance Combine Bool where
combine l1 l2 = l1 || l2
instance Combine (Program DebugToCSemanticInfo) where
combine (Empty _ _) p2 = p2
combine p1 _ = p1
-----------------------------------------------------
--- GetPrg plugin for ParLoop
-----------------------------------------------------
data GetPrgParLoop = GetPrgParLoop
instance Transformation GetPrgParLoop where
type From GetPrgParLoop = DebugToCSemanticInfo
type To GetPrgParLoop = DebugToCSemanticInfo
type Down GetPrgParLoop = (Int, Int)
type Up GetPrgParLoop = (Bool, Program DebugToCSemanticInfo)
type State GetPrgParLoop = ()
instance Plugin GetPrgParLoop where
type ExternalInfo GetPrgParLoop = (Int, Int)
executePlugin GetPrgParLoop (line, col) procedure =
result $ transform GetPrgParLoop () (line, col) procedure
getPrgParLoop :: (Int, Int) -> Module DebugToCSemanticInfo -> (Bool, Program DebugToCSemanticInfo)
getPrgParLoop (line, col) procedure = up res where
res = transform GetPrgParLoop () (line, col) procedure
instance Transformable GetPrgParLoop Program where
transform t () (line, col) pl@(ParLoop _ _ _ prog inf1 inf2) = Result pl () info where
info = case contains (line, col) inf1 of
True -> infoCr where
res = transform t () (line, col) prog
infoCr = case (fst $ up res) of
True -> up res
_ -> (True, pl)
_ -> def
transform t () (line, col) pr = defaultTransform t () (line, col) pr
-----------------------------------------------------
--- GetPrg plugin for Assign
-----------------------------------------------------
data GetPrgAssign = GetPrgAssign
instance Transformation GetPrgAssign where
type From GetPrgAssign = DebugToCSemanticInfo
type To GetPrgAssign = DebugToCSemanticInfo
type Down GetPrgAssign = (Int, Int)
type Up GetPrgAssign = (Bool, Program DebugToCSemanticInfo)
type State GetPrgAssign = ()
instance Plugin GetPrgAssign where
type ExternalInfo GetPrgAssign = (Int, Int)
executePlugin GetPrgAssign (line, col) procedure =
result $ transform GetPrgAssign () (line, col) procedure
getPrgAssign :: (Int, Int) -> Module DebugToCSemanticInfo -> (Bool, Program DebugToCSemanticInfo)
getPrgAssign (line, col) procedure = up res where
res = transform GetPrgAssign () (line, col) procedure
instance Transformable GetPrgAssign Program where
transform t () (line, col) assign@(Assign _ _ inf1 inf2) = Result assign () info where
info = case contains (line, col) inf1 of
True -> (True, assign)
_ -> def
transform t () (line, col) pr = defaultTransform t () (line, col) pr
-----------------------------------------------------
--- GetPrg plugin for Branch
-----------------------------------------------------
data GetPrgBranch = GetPrgBranch
instance Transformation GetPrgBranch where
type From GetPrgBranch = DebugToCSemanticInfo
type To GetPrgBranch = DebugToCSemanticInfo
type Down GetPrgBranch = (Int, Int)
type Up GetPrgBranch = (Bool, Program DebugToCSemanticInfo)
type State GetPrgBranch = ()
instance Plugin GetPrgBranch where
type ExternalInfo GetPrgBranch = (Int, Int)
executePlugin GetPrgBranch (line, col) procedure =
result $ transform GetPrgBranch () (line, col) procedure
getPrgBranch :: (Int, Int) -> Module DebugToCSemanticInfo -> (Bool, Program DebugToCSemanticInfo)
getPrgBranch (line, col) procedure = up res where
res = transform GetPrgBranch () (line, col) procedure
instance Transformable GetPrgBranch Program where
transform t () (line, col) br@(Branch _ prog1 prog2 inf1 inf2) = Result br () info where
info = case contains (line, col) inf1 of
True -> infoCr where
res1 = transform t () (line, col) prog1
res2 = transform t () (line, col) prog2
res = combine (up res1) (up res2)
infoCr = case (fst res) of
True -> res
_ -> (True, br)
_ -> def
transform t () (line, col) pr = defaultTransform t () (line, col) pr
-----------------------------------------------------
--- GetPrg plugin for ProcedureCall
-----------------------------------------------------
data GetPrgProcCall = GetPrgProcCall
instance Transformation GetPrgProcCall where
type From GetPrgProcCall = DebugToCSemanticInfo
type To GetPrgProcCall = DebugToCSemanticInfo
type Down GetPrgProcCall = (Int, Int)
type Up GetPrgProcCall = (Bool, Program DebugToCSemanticInfo)
type State GetPrgProcCall = ()
instance Plugin GetPrgProcCall where
type ExternalInfo GetPrgProcCall = (Int, Int)
executePlugin GetPrgProcCall (line, col) procedure =
result $ transform GetPrgProcCall () (line, col) procedure
getPrgProcCall :: (Int, Int) -> Module DebugToCSemanticInfo -> (Bool, Program DebugToCSemanticInfo)
getPrgProcCall (line, col) procedure = up res where
res = transform GetPrgProcCall () (line, col) procedure
instance Transformable GetPrgProcCall Program where
transform t () (line, col) pc@(ProcedureCall _ _ inf1 inf2) = Result pc () info where
info = case contains (line, col) inf1 of
True -> (True, pc)
_ -> def
transform t () (line, col) pr = defaultTransform t () (line, col) pr
-----------------------------------------------------
--- GetPrg plugin for SeqLoop
-----------------------------------------------------
data GetPrgSeqLoop = GetPrgSeqLoop
instance Transformation GetPrgSeqLoop where
type From GetPrgSeqLoop = DebugToCSemanticInfo
type To GetPrgSeqLoop = DebugToCSemanticInfo
type Down GetPrgSeqLoop = (Int, Int)
type Up GetPrgSeqLoop = (Bool, Program DebugToCSemanticInfo)
type State GetPrgSeqLoop = ()
instance Plugin GetPrgSeqLoop where
type ExternalInfo GetPrgSeqLoop = (Int, Int)
executePlugin GetPrgSeqLoop (line, col) procedure =
result $ transform GetPrgSeqLoop () (line, col) procedure
getPrgSeqLoop :: (Int, Int) -> Module DebugToCSemanticInfo -> (Bool, Program DebugToCSemanticInfo)
getPrgSeqLoop (line, col) procedure = up res where
res = transform GetPrgSeqLoop () (line, col) procedure
instance Transformable GetPrgSeqLoop Program where
transform t () (line, col) sl@(SeqLoop _ _ prog inf1 inf2) = Result sl () info where
info = case contains (line, col) inf1 of
True -> infoCr where
res = transform t () (line, col) prog
infoCr = case (fst $ up res) of
True -> up res
_ -> (True, sl)
_ -> def
transform t () (line, col) pr = defaultTransform t () (line, col) pr
-------------------------------------------------
------ Helper functions
-------------------------------------------------
contains (line, col) ((bl, bc), (el, ec)) = (line == bl && bc <= col) || (bl < line && line < el) || (line == el && col <= ec)
myShow :: Program DebugToCSemanticInfo -> String
myShow (Assign lhs rhs inf1 inf2) = "Assign \n" ++ ind show lhs ++ "\n=\n" ++ ind show rhs ++ "\n" ++ show inf1 ++ "\n"
myShow (Sequence progs inf1 inf2) = "Sequence\n" ++ ind (listprint myShow "\n") progs ++ "\n" ++ show inf1 ++ "\n"
myShow (Branch cond thenBlock elseBlock inf1 inf2) = "Branch\n" ++ ind myShowB thenBlock ++ "\nelse\n" ++ ind myShowB elseBlock ++ "\n" ++ show inf1 ++ "\n"
myShow (ParLoop count bound step block inf1 inf2)
= "ParLoop\n count: " ++ show count ++ "\n bound: " ++ show bound ++ "\n step: " ++ show step ++ "\n" ++ ind myShowB block ++ "\n" ++ show inf1 ++ "\n"
myShow x = show x
myShowB :: Block DebugToCSemanticInfo -> String
myShowB (Block locals prg inf) = "Block\n" ++ ind show locals ++"\n" ++ ind myShow prg ++ show inf