module GcodeLowC
( gcodeGather
, gcodeCHeader
) where
#if defined(__HBC__)
#define NATIVE
#elif defined(__NHC__)
#define NHCFLOAT
#elif defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 406
#define NATIVE
#elif defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 406
#define FLOAT
#elif defined(__HUGS__)
#define HUGSFLOAT
#endif
import Gcode
import GcodeLow (shortNeedheap,shortNeedstack,shortPush,shortPop
,shortPushArg,shortZapArg,shortHeapCval,shortHeap
,fun,foreignfun,showId)
import EmitState
import Prim(strPrim)
#if defined(NATIVE)
import Native
#elif defined(NHCFLOAT)
import NhcFloats
#elif defined(FLOAT)
import Floats
#endif
sfun = fun
ffun = foreignfun
----------------------------------------
gcodeCHeader = "#include \"newmacros.h\"\n#include \"runtime.h\"\n\n"
----------------------------------------
emitJump p j i =
emitByte p (j) >|>
emitByte p (show l) >|>
emitByte p (show h)
where
(h,l) = divMod i 256
emitOp p op = emitByte p (op)
emitOp1 p op i =
emitByte p (op) >|>
emitByte p (show i)
emitOp2 p op i j =
emitByte p (op) >|>
emitByte p (show i) >|>
emitByte p (show j)
emitOp12 p op i =
if i < 0 then
case (-i) `divMod` 256 of
(0,l) -> emitByte p (op ++ "_N1") >|>
emitByte p (show l)
(h,l) -> emitByte p (op ++ "_N2") >|>
emitByte p (show l) >|>
emitByte p (show h)
else
case i `divMod` 256 of
(0,l) -> emitByte p (op ++ "_P1") >|>
emitByte p (show l)
(h,l) -> emitByte p (op ++ "_P2") >|>
emitByte p (show l) >|>
emitByte p (show h)
shortQ p pred defgen opstr arg =
case pred arg of
(True,argstr) -> emitOp p (opstr ++ "_I" ++ argstr)
_ -> defgen opstr arg
gcodeCDump p state (ALIGN) = emitAlign p
gcodeCDump p state (ALIGN_CONST) = emitOp p "ENDCODE" >|> emitAlignDouble p
gcodeCDump p state (NEEDHEAP i) = shortQ p shortNeedheap (emitOp12 p)
"NEEDHEAP" i
gcodeCDump p state (NEEDSTACK i) = shortQ p shortNeedstack (emitOp12 p)
"NEEDSTACK" i
gcodeCDump p state (LABEL i) = defineLabel p Local (showId state i "")
gcodeCDump p state (LOCAL s i) = defineLabel p Local
(s ++ showId state i "")
gcodeCDump p state (GLOBAL s i) = defineLabel p Global
(s ++ showId state i "")
gcodeCDump p state (JUMP i) = emitJump p "JUMP" i
gcodeCDump p state (JUMPFALSE i) = emitJump p "JUMPFALSE" i -- DAVID
gcodeCDump p state (PRIMITIVE) = emitOp p "PRIMITIVE"
gcodeCDump p state (PRIM prim) = emitOp p (strPrim prim)
gcodeCDump p state (NOP) = emitOp p "NOP"
gcodeCDump p state (MKIORETURN) = emitOp p "MKIORETURN" -- MW
gcodeCDump p state (TABLESWITCH size pad ls) = -- DAVID
emitOp1 p "TABLESWITCH" size >|>
someNops p pad >|>
someLabels p ls
gcodeCDump p state (LOOKUPSWITCH size pad tls def) = -- DAVID
emitOp1 p "LOOKUPSWITCH" size >|>
someNops p pad >|>
someLabels p (concatMap (\(f,s) -> [f,s]) tls ++ [def])
gcodeCDump p state (ZAP_ARG i) = shortQ p shortZapArg (emitOp1 p)
"ZAP_ARG" i
gcodeCDump p state (ZAP_STACK i) = emitOp12 p "ZAP_STACK" i
-- Stack
gcodeCDump p state (PUSH_CADR i) = emitOp12 p "PUSH_CADR" i
gcodeCDump p state (PUSH_CVAL i) = emitOp12 p "PUSH_CVAL" i
gcodeCDump p state (PUSH_INT i) = emitOp12 p "PUSH_INT" i
gcodeCDump p state (PUSH_CHAR i) = emitOp12 p "PUSH_CHAR" i
gcodeCDump p state (PUSH_ARG i) = shortQ p shortPushArg (emitOp1 p)
"PUSH_ARG" i
gcodeCDump p state (PUSH_ZAP_ARG i) = shortQ p shortPushArg (emitOp1 p)
"PUSH_ZAP_ARG" i
gcodeCDump p state (PUSH i) = shortQ p shortPush (emitOp12 p) "PUSH" i
gcodeCDump p state (PUSH_HEAP) = emitOp p "PUSH_HEAP"
gcodeCDump p state (POP i) = shortQ p shortPop (emitOp12 p) "POP" i
gcodeCDump p state (SLIDE i) = emitOp12 p "SLIDE" i
gcodeCDump p state (UNPACK i) = emitOp1 p "UNPACK" i
-- selector
gcodeCDump p state (SELECTOR_EVAL) = emitOp p "SELECTOR_EVAL"
gcodeCDump p state (SELECT i) = emitOp1 p "SELECT" i
-- evaluation
gcodeCDump p state (APPLY i) = emitOp1 p "APPLY" i
gcodeCDump p state (EVAL) = emitOp p "EVAL"
gcodeCDump p state (RETURN) = emitOp p "RETURN"
gcodeCDump p state (RETURN_EVAL) = emitOp p "RETURN_EVAL"
-- Heap
gcodeCDump p state (HEAP_CADR i) = emitOp12 p "HEAP_CADR" i
gcodeCDump p state (HEAP_CVAL i) = shortQ p shortHeapCval (emitOp12 p)
"HEAP_CVAL" i
gcodeCDump p state (HEAP_INT i) = emitOp12 p "HEAP_INT" i
gcodeCDump p state (HEAP_CHAR i) = emitOp12 p "HEAP_CHAR" i
gcodeCDump p state (HEAP_ARG i) = emitOp1 p "HEAP_ARG" i
gcodeCDump p state (HEAP_ARG_ARG i j) = emitOp2 p "HEAP_ARG_ARG" i j
gcodeCDump p state (HEAP_ARG_ARG_RET_EVAL i j) =
emitOp2 p "HEAP_ARG_ARG_RET_EVAL" i j
gcodeCDump p state (HEAP i) = shortQ p shortHeap (emitOp12 p) "HEAP" i
gcodeCDump p state (HEAP_OFF i) = emitOp12 p "HEAP_OFF" i
gcodeCDump p state (HEAP_CREATE) = emitOp p "HEAP_CREATE"
gcodeCDump p state (HEAP_SPACE) = emitOp p "HEAP_SPACE"
gcodeCDump p state (DATA_CREATE) = emitWord p ("0")
gcodeCDump p state (DATA_CAPITEM a b) = emitByte p (show b) >|>
emitByte p (show a)
gcodeCDump p state (DATA_CONSTHEADER a b) = emitWord p ("HW(" ++
show a ++ ',':
show b ++ ")")
gcodeCDump p state (DATA_W i) = emitWord p (show i)
gcodeCDump p state (DATA_S s) = foldr (>|>) (emitByte p ("0"))
(map (emitByte p.show.fromEnum) s)
#if defined(NATIVE)
gcodeCDump p state (DATA_F f) = {-no need to test if floatIsDouble-}
let bytes = showBytes f [] in
foldr (>|>) id
(map (emitByte p.show.fromEnum) bytes)
gcodeCDump p state (DATA_D d) = let bytes = showBytes d [] in
foldr (>|>) id
(map (emitByte p.show.fromEnum) bytes)
#elif defined(NHCFLOAT)
gcodeCDump p state (DATA_F f) = {-if floatIsDouble then
let (h,l) = doubleToInts f in
emitWord p (show h) >|>
emitWord p (show l)
else-}
let i = floatToInt f in
emitWord p (show i)
gcodeCDump p state (DATA_D d) = let (h,l) = doubleToInts d in
emitWord p (show h) >|>
emitWord p (show l)
#elif defined(FLOAT)
gcodeCDump p state (DATA_F f) = {-if floatIsDouble then
let h = doubleToInt0 f
l = doubleToInt1 f in
emitWord p (show h) >|>
emitWord p (show l)
else-}
let i = floatToInt f in
emitWord p (show i)
gcodeCDump p state (DATA_D d) = let h = doubleToInt0 d
l = doubleToInt1 d in
emitWord p (show h) >|>
emitWord p (show l)
#elif defined(HUGSFLOAT)
-- does not work, just bogus translation of floats and doubles into zero bytes
gcodeCDump p state (DATA_F f) = {-if floatIsDouble then
let h = 0
l = 0 in
emitWord p (show h) >|>
emitWord p (show l)
else-}
let i = 0 in
emitWord p (show i)
gcodeCDump p state (DATA_D d) = let h = 0
l = 0 in
emitWord p (show h) >|>
emitWord p (show l)
#endif
gcodeCDump p state (DATA_NOP) = id
gcodeCDump p state (DATA_CLABEL i) = useLabel p (showCLabel state i "")
gcodeCDump p state (DATA_FLABEL i) = useLabel p (ffun ++ showId state i "")
gcodeCDump p state (DATA_GLB s 0) = useLabel p (s)
gcodeCDump p state (DATA_GLB s i) = useLabel p (s ++ showId state i "")
gcodeCDump p state (DATA_VAP i) = let lab = sfun ++ showId state i ""
in
mentionLabel p lab >|>
emitWord p ("VAPTAG(" ++
wrapUse lab ++ ")")
gcodeCDump p state (DATA_CAP i s) = let lab = sfun ++ showId state i ""
in
mentionLabel p lab >|>
emitWord p ("CAPTAG(" ++
wrapUse lab ++
',': show s ++ ")")
gcodeCDump p state (DATA_CON s c) = emitWord p ("CONSTR(" ++
show c ++ ',':
show s ++ ",0)")
gcodeCDump p state (DATA_CONW s e) = emitWord p ("CONSTRW(" ++
show s ++ ',':
show e ++ ")")
gcodeCDump p state (DATA_CONP s e) = emitWord p ("CONSTRP(" ++
show s ++ ',':
show e ++ ")")
someNops :: Pass -> Int -> EmitState -> EmitState
someNops p pad = foldr (>|>) id (take pad (repeat (emitOp p "NOP")))
someLabels :: Pass -> [ Int ] -> EmitState -> EmitState
someLabels p cls =
foldr (>|>) id (map (\l -> emitByte p ("TOP(" ++ show l ++ ")") >|>
emitByte p ("BOT(" ++ show l ++ ")")
)
cls)
----------------------------------------
gcodeGather p state es [] = es
gcodeGather p state es list =
(foldr (\a b-> gcodeCDump p state a >|> b) (emitAlign p) list) es
|
