GcodeLow is imported by: EmitState, Foreign, GcodeFix, GcodeLowC, GcodeMem, GcodeOpt1, GcodeRel, GcodeSpec, Main, STGBuild, STGGcode, STGState.
module GcodeLow (offsetSize ,shortNeedheap,shortNeedstack,shortPush,shortPop ,shortPushArg,shortZapArg,shortHeapCval,shortHeap ,gcodeSize,gcodeNeed,primNeed,primStack,gcodeStack ,gcodeDump,gcodeHeader ,lowInteger,extra ,wsize,con0,cap0,caf,fun,cfun,string,consttable,foreignfun ,profstatic,profmodule,tprofmodule,tprofmodulesub ,proftype,profproducer,profconstructor,align ,fixStr,showId ) where import Char import Gcode import Extra(strStr,splitIntegral,SplitIntegral(..)) import IntState(strIS,IntState,dummyIntState) import Prim(strPrim) import Machine extra = 4::Int -- make room for largest profile info align :: Int -> Int -> Int align a p = case p `mod` a of 0 -> 0 x -> a-x con0 = "C0_" cap0 = "F0_" caf = "CF_" fun = "FN_" cfun = "" string = "ST_" consttable = "CT_" foreignfun = "FR_" profstatic = "PS_" profmodule = "PM_" proftype = "PT_" profproducer = "PP_" profconstructor = "PC_" tprofmodule = "TM_" tprofmodulesub = "TMSUB_" groupW [] = [] groupW xs = case splitAt wsize xs of (w,xs) -> take wsize (w ++ repeat 0) : groupW xs fixW xs = foldr ( \ d a -> d+256*a ) 0 xs lowInteger i = case splitIntegral i of SplitNeg xs -> let xsW = groupW xs in DATA_CONW (length xsW) 1 : map (DATA_W . fixW) xsW SplitZero -> [DATA_CONW 0 0 ] SplitPos xs -> let xsW = groupW xs in DATA_CONW (length xsW) 0 : map (DATA_W . fixW) xsW offsetSize i = if i >=256 || i<= -256 then 2 else 1 shortNeedheap :: Int -> (Bool,String) shortNeedheap i = (i <= 32,"32") shortNeedstack :: Int -> (Bool,String) shortNeedstack i = (i <= 16,"16") shortPush :: Int -> (Bool,String) shortPush i = (i==1,"1") shortPop :: Int -> (Bool,String) shortPop i = (i==1,"1") shortPushArg :: Int -> (Bool,String) shortPushArg i = (1<= i && i <= 3, show i) shortZapArg :: Int -> (Bool,String) shortZapArg i = (1<= i && i <= 3, show i) shortHeapCval :: Int -> (Bool,String) shortHeapCval i = (i == -3 || (3<= i && i <= 5), if i == -3 then "N3" else show i) shortHeap :: Int -> (Bool,String) shortHeap i = (i==1 || i==2, show i) gcodeSize (NEEDHEAP i) = if fst(shortNeedheap i) then 1 else 1 + offsetSize i gcodeSize (NEEDSTACK i) = if fst(shortNeedstack i) then 1 else 1 + offsetSize i gcodeSize (LABEL i) = 0 gcodeSize (LOCAL s i) = 0 gcodeSize (GLOBAL s i) = 0 gcodeSize (JUMP i) = 3 gcodeSize (JUMPFALSE i) = 3 -- DAVID gcodeSize (PRIMITIVE) = 1 gcodeSize (PRIM prim) = 1 gcodeSize (NOP) = 1 gcodeSize (TABLESWITCH size pad ls) = 2 + pad + size * 2 -- DAVID gcodeSize (LOOKUPSWITCH size pad tls def) = 2 + pad + size * 4 + 2 -- DAVID gcodeSize (MKIORETURN) = 1 -- MW
{------- DAVID ------------
gcodeSize (MATCHCON) = 1
gcodeSize (MATCHINT) = 1
gcodeSize (JUMPS_T) = 1
gcodeSize (JUMPTABLE l) = 2
gcodeSize (JUMPS_L) = 1
gcodeSize (JUMPLENGTH s l) = 4
gcodeSize (JUMPLIST v l) = 4
--------- DAVID ---------- -}
gcodeSize (ZAP_STACK i) = 1 + offsetSize i gcodeSize (ZAP_ARG i) = if fst (shortZapArg i) then 1 else 2 -- Stack gcodeSize (PUSH_CADR i) = 1 + offsetSize i gcodeSize (PUSH_CVAL i) = 1 + offsetSize i gcodeSize (PUSH_INT i) = 1 + offsetSize i gcodeSize (PUSH_CHAR i) = 1 + offsetSize i gcodeSize (PUSH_ARG i) = if fst (shortPushArg i) then 1 else 2 gcodeSize (PUSH_ZAP_ARG i) = if fst (shortPushArg i) then 1 else 2 gcodeSize (PUSH i) = if fst (shortPush i) then 1 else 1 + offsetSize i gcodeSize (PUSH_HEAP) = 1 gcodeSize (POP i) = if fst (shortPop i) then 1 else 1 + offsetSize i gcodeSize (SLIDE i) = 1 + offsetSize i gcodeSize (UNPACK i) = 2 -- selector gcodeSize (SELECTOR_EVAL) = 1 gcodeSize (SELECT i) = 2 -- evaluation gcodeSize (APPLY i) = 2 gcodeSize (EVAL) = 1 gcodeSize (RETURN) = 1 gcodeSize (RETURN_EVAL) = 1 -- Heap gcodeSize (HEAP_CADR i) = 1 + offsetSize i gcodeSize (HEAP_CVAL i) = if fst (shortHeapCval i) then 1 else 1 + offsetSize i gcodeSize (HEAP_INT i) = 1 + offsetSize i gcodeSize (HEAP_CHAR i) = 1 + offsetSize i gcodeSize (HEAP_ARG i) = 2 gcodeSize (HEAP_ARG_ARG i j) = 3 gcodeSize (HEAP_ARG_ARG_RET_EVAL i j) = 3 gcodeSize (HEAP i) = if fst (shortHeap i) then 1 else 1 + offsetSize i gcodeSize (HEAP_OFF i) = 1 + offsetSize i gcodeSize (HEAP_CREATE) = 1 gcodeSize (HEAP_SPACE) = 1 gcodeSize (DATA_CREATE) = wsize gcodeSize (DATA_CAPITEM a b ) = 2 gcodeSize (DATA_CONSTHEADER a b) = wsize gcodeSize (DATA_W i) = wsize gcodeSize (DATA_F f) = if floatIsDouble then 8 else 4 gcodeSize (DATA_S s) = wsize gcodeSize (DATA_D d) = 8 gcodeSize (DATA_NOP) = 0 gcodeSize (DATA_CLABEL i) = wsize gcodeSize (DATA_FLABEL i) = wsize gcodeSize (DATA_GLB s i) = wsize gcodeSize (DATA_VAP i) = wsize gcodeSize (DATA_CAP i s) = wsize gcodeSize (DATA_CON s c) = wsize gcodeSize (DATA_CONR s c) = wsize gcodeSize (DATA_CONT s c) = wsize gcodeSize (DATA_CONW s e) = wsize gcodeSize (DATA_CONP s e) = wsize gcodeStack g = fst (gcodeNeed 0 g) gcodeNeed :: Int -> Gcode -> (Int,Int) gcodeNeed extra (PUSH_CADR i) = ( 1,0) gcodeNeed extra (PUSH_CVAL i) = ( 1,0) gcodeNeed extra (PUSH_INT i) = ( 1,0) gcodeNeed extra (PUSH_CHAR i) = ( 1,0) gcodeNeed extra (PUSH_ARG i) = ( 1,0) gcodeNeed extra (PUSH_ZAP_ARG i) = ( 1,0) -- gcodeNeed extra (PUSH i) = ( 1,0) gcodeNeed extra (PUSH_HEAP) = ( 1,0) gcodeNeed extra (POP i) = (-i,0) -- gcodeNeed extra (SLIDE i) = (-i,0) -- gcodeNeed extra (UNPACK i) = (i-1,0) -- gcodeNeed extra (SELECTOR_EVAL)= ( 1,0) -- gcodeNeed extra (RETURN) = (-1,0) -- gcodeNeed extra (RETURN_EVAL) = (-1,0) -- gcodeNeed extra (APPLY i) = (-i,10+i*(3+extra)) -- Not always correct (10 is a large application but they can be larger) gcodeNeed extra (HEAP_CADR i) = (0,1) gcodeNeed extra (HEAP_CVAL i) = (0,1) gcodeNeed extra (HEAP_INT i) = (0,1) gcodeNeed extra (HEAP_CHAR i) = (0,1) gcodeNeed extra (HEAP_ARG i) = (0,1) gcodeNeed extra (HEAP_ARG_ARG i j) = (0,2) gcodeNeed extra (HEAP_ARG_ARG_RET_EVAL i j) = (0,2) gcodeNeed extra (HEAP i) = (0,1) gcodeNeed extra (HEAP_OFF i) = (0,1) gcodeNeed extra (HEAP_CREATE) = (0,1) gcodeNeed extra (HEAP_SPACE) = (0,1) gcodeNeed extra (NEEDSTACK i) = (0,0) gcodeNeed extra (ALIGN ) = (0,0) gcodeNeed extra (ALIGN_CONST) = (0,0) gcodeNeed extra (DATA_CREATE) = (0,0) gcodeNeed extra (DATA_CAPITEM _ _)=(0,0) gcodeNeed extra (DATA_CONSTHEADER _ _) = (0,0) gcodeNeed extra (DATA_W _) = (0,0) gcodeNeed extra (DATA_S _) = (0,0) gcodeNeed extra (DATA_F _) = (0,0) gcodeNeed extra (DATA_D _) = (0,0) gcodeNeed extra (DATA_NOP) = (0,0) -- does not generate anything, used after DATA_D to keep 1 DATA/WORD gcodeNeed extra (DATA_CLABEL _) = (0,0) gcodeNeed extra (DATA_FLABEL _) = (0,0) gcodeNeed extra (DATA_GLB _ _) = (0,0) gcodeNeed extra (DATA_VAP _) = (0,0) gcodeNeed extra (DATA_CAP _ _) = (0,0) gcodeNeed extra (DATA_CON _ _) = (0,0) gcodeNeed extra (DATA_CONR _ _) = (0,0) gcodeNeed extra (DATA_CONT _ _) = (0,0) gcodeNeed extra (DATA_CONW _ _) = (0,0) gcodeNeed extra (DATA_CONP _ _) = (0,0) -- gcodeNeed extra MATCHCON = (0,0) -- DAVID -- gcodeNeed extra MATCHINT = (0,0) -- DAVID gcodeNeed extra (MKIORETURN) = (0,2) -- MW gcodeNeed extra g = error ("gcodeNeed " ++ strGcode dummyIntState g) primStack prim = fst (primNeed 0 prim) primNeed :: Int -> Prim -> (Int,Int) primNeed extra (ADD op) = (-1,opNeed extra op) primNeed extra (SUB op) = (-1,opNeed extra op) primNeed extra (MUL op) = (-1,opNeed extra op) primNeed extra (ABS op) = ( 0,opNeed extra op) primNeed extra (SIGNUM op) = ( 0,opNeed extra op) primNeed extra (EXP op) = ( 0,opNeed extra op) primNeed extra (LOG op) = ( 0,opNeed extra op) primNeed extra (SQRT op) = ( 0,opNeed extra op) primNeed extra (SIN op) = ( 0,opNeed extra op) primNeed extra (COS op) = ( 0,opNeed extra op) primNeed extra (TAN op) = ( 0,opNeed extra op) primNeed extra (ASIN op) = ( 0,opNeed extra op) primNeed extra (ACOS op) = ( 0,opNeed extra op) primNeed extra (ATAN op) = ( 0,opNeed extra op) primNeed extra (SLASH op) = (-1,opNeed extra op) primNeed extra (CMP_EQ op) = (-1,0) primNeed extra (CMP_NE op) = (-1,0) primNeed extra (CMP_LT op) = (-1,0) primNeed extra (CMP_LE op) = (-1,0) primNeed extra (CMP_GT op) = (-1,0) primNeed extra (CMP_GE op) = (-1,0) primNeed extra (NEG op) = ( 0,opNeed extra op) primNeed extra (QUOT) = (-1,2+extra) primNeed extra (REM) = (-1,2+extra) primNeed extra (AND) = (-1,0) primNeed extra (OR) = (-1,0) primNeed extra (NOT) = ( 0,0) primNeed extra (ORD) = ( 0,2+extra) primNeed extra (CHR) = ( 0,1+extra) primNeed extra (SEQ) = (-1,0) primNeed extra (STRING) = ( 0,3+2+3+3*extra) primNeed extra (HGETS) = ( 0,3+2+3+3*extra ) primNeed extra (HGETC) = ( 0, 2+extra ) primNeed extra (HPUTC) = ( -1, 2+extra ) opNeed :: Int -> PrimOp -> Int opNeed extra OpWord = 2+extra opNeed extra OpFloat = 2+extra opNeed extra OpDouble = 3+extra showId state i = fixStr (strIS state i) fixStr [] = id fixStr (c:cs) = if isAlphaNum c then showChar c . fixStr cs else showChar '_' . shows (fromEnum c) . fixStr cs showJump j i = showString " DB " . showString j . showChar ',' . shows l . showChar ',' . shows h . showChar '\n' where (h,l) = divMod i 256 showOp op = showString " DB " . showString op . showChar '\n' showOp1 op i = showString " DB " . showString op . showChar ',' . shows i . showChar '\n' showOp2 op i j = showString " DB " . showString op . showChar ',' . shows i . showChar ',' . shows j . showChar '\n' showOp12 op i = if i < 0 then case (-i) `divMod` 256 of (0,l) -> showString " DB " . showString op . showString "_N1," . shows l . showChar '\n' (h,l) -> showString " DB " . showString op . showString "_N2," . shows l . showChar ',' . shows h . showChar '\n' else case i `divMod` 256 of (0,l) -> showString " DB " . showString op . showString "_P1," . shows l . showChar '\n' (h,l) -> showString " DB " . showString op . showString "_P2," . shows l . showChar ',' . shows h . showChar '\n' gcodeHeader = showString "#include \"codemacros.h\"\n\n STARTBYTECODE\n AL\n" shortQ pred defgen opstr arg = case pred arg of (True,argstr) -> showOp (opstr ++ "_I" ++ argstr) _ -> defgen opstr arg gcodeDump state (ALIGN) = showString " AL\n" -- gcodeDump state (ALIGN_CONST) = showString " AL_D\n" -- DAVID gcodeDump state (ALIGN_CONST) = showOp "ENDCODE" . showString " AL_D\n" --DAVID gcodeDump state (NEEDHEAP i) = shortQ shortNeedheap showOp12 "NEEDHEAP" i gcodeDump state (NEEDSTACK i) = shortQ shortNeedstack showOp12 "NEEDSTACK" i gcodeDump state (LABEL i) = showString "DL(" . showId state i . showString ")\n" gcodeDump state (LOCAL s i) = showString "DL(" . showString s . showId state i . showString ")\n" gcodeDump state (GLOBAL s i) = let l = showString s . showId state i in showString " EX L(" . l . showString ")\nDL(" . l . showString ")\n" gcodeDump state (JUMP i) = showJump "JUMP" i gcodeDump state (JUMPFALSE i) = showJump "JUMPFALSE" i -- DAVID gcodeDump state (PRIMITIVE) = showOp "PRIMITIVE" gcodeDump state (PRIM prim) = showOp (strPrim prim) gcodeDump state (NOP) = showOp "NOP" gcodeDump state (TABLESWITCH size pad ls) = -- DAVID showOp1 "TABLESWITCH" size . someNops pad . someLabels ls gcodeDump state (LOOKUPSWITCH size pad tls def) = -- DAVID showOp1 "LOOKUPSWITCH" size . someNops pad . someLabels (concatMap (\(f,s) -> [f,s]) tls ++ [def]) gcodeDump state (MKIORETURN) = showOp "MKIORETURN" -- MW
{----------- DAVID ---------------
gcodeDump state (MATCHCON) = showOp "MATCHCON"
gcodeDump state (MATCHINT) = showOp "MATCHINT"
gcodeDump state (JUMPS_T) = showOp "JUMPS_T"
gcodeDump state (JUMPTABLE l) = showString " JT(" . shows l . showString ")\n"
gcodeDump state (JUMPS_L) = showOp "JUMPS_L"
gcodeDump state (JUMPLENGTH v l) = showString " JT(" . shows v . showString ")\n JT(" . shows l . showString ")\n"
gcodeDump state (JUMPLIST v l) = showString " JT(" . shows v . showString ")\n JT(" . shows l . showString ")\n"
------------ DAVID ---------------- -}
gcodeDump state (ZAP_ARG i) = shortQ shortZapArg showOp1 "ZAP_ARG" i gcodeDump state (ZAP_STACK i) = showOp12 "ZAP_STACK" i -- Stack gcodeDump state (PUSH_CADR i) = showOp12 "PUSH_CADR" i gcodeDump state (PUSH_CVAL i) = showOp12 "PUSH_CVAL" i gcodeDump state (PUSH_INT i) = showOp12 "PUSH_INT" i gcodeDump state (PUSH_CHAR i) = showOp12 "PUSH_CHAR" i gcodeDump state (PUSH_ARG i) = shortQ shortPushArg showOp1 "PUSH_ARG" i gcodeDump state (PUSH_ZAP_ARG i)= shortQ shortPushArg showOp1 "PUSH_ZAP_ARG" i gcodeDump state (PUSH i) = shortQ shortPush showOp12 "PUSH" i gcodeDump state (PUSH_HEAP) = showOp "PUSH_HEAP" gcodeDump state (POP i) = shortQ shortPop showOp12 "POP" i gcodeDump state (SLIDE i) = showOp12 "SLIDE" i gcodeDump state (UNPACK i) = showOp1 "UNPACK" i -- selector gcodeDump state (SELECTOR_EVAL) = showOp "SELECTOR_EVAL" gcodeDump state (SELECT i) = showOp1 "SELECT" i -- evaluation gcodeDump state (APPLY i) = showOp1 "APPLY" i gcodeDump state (EVAL) = showOp "EVAL" gcodeDump state (RETURN) = showOp "RETURN" gcodeDump state (RETURN_EVAL) = showOp "RETURN_EVAL" -- Heap gcodeDump state (HEAP_CADR i) = showOp12 "HEAP_CADR" i gcodeDump state (HEAP_CVAL i) = shortQ shortHeapCval showOp12 "HEAP_CVAL" i gcodeDump state (HEAP_INT i) = showOp12 "HEAP_INT" i gcodeDump state (HEAP_CHAR i) = showOp12 "HEAP_CHAR" i gcodeDump state (HEAP_ARG i) = showOp1 "HEAP_ARG" i gcodeDump state (HEAP_ARG_ARG i j) = showOp2 "HEAP_ARG_ARG" i j gcodeDump state (HEAP_ARG_ARG_RET_EVAL i j) = showOp2 "HEAP_ARG_ARG_RET_EVAL" i j gcodeDump state (HEAP i) = shortQ shortHeap showOp12 "HEAP" i gcodeDump state (HEAP_OFF i) = showOp12 "HEAP_OFF" i gcodeDump state (HEAP_CREATE) = showOp "HEAP_CREATE" gcodeDump state (HEAP_SPACE) = showOp "HEAP_SPACE" gcodeDump state (DATA_CREATE) = showString " DW 0\n" gcodeDump state (DATA_CAPITEM a b) = showString " DB " . shows b . showChar ',' . shows a . showChar '\n' gcodeDump state (DATA_CONSTHEADER a b) = showString " DW HW(" . shows a . showChar ',' . shows b . showString ")\n" gcodeDump state (DATA_W i) = showString " DW " . shows i . showChar '\n' gcodeDump state (DATA_F f) = if floatIsDouble then showString " DD(" . shows f . showString ")\n" else showString " DF(" . shows f . showString ")\n" gcodeDump state (DATA_S s) = chopString s where chopString "" = showString " DB 0\n AL\n" -- DAVID chopString x = case splitAt (40::Int) x of (x,xs) -> showString " DS " . showString (strStr x) . showString "\n" . chopString xs gcodeDump state (DATA_D d) = showString " DD(" . shows d . showString ")\n" gcodeDump state (DATA_NOP) = id gcodeDump state (DATA_CLABEL i) = showString " DW L(" . showCLabel state i . showString ")\n" gcodeDump state (DATA_FLABEL i) = showString " DW L(" . showString foreignfun . showId state i . showString ")\n" gcodeDump state (DATA_GLB s 0) = showString " DW L(" . showString s . showString ")\n" gcodeDump state (DATA_GLB s i) = showString " DW L(" . showString s . showId state i . showString ")\n" gcodeDump state (DATA_VAP i) = showString " DW VAPTAG(" . showString fun . showId state i . showString ")\n" gcodeDump state (DATA_CAP i s) = showString " DW CAPTAG(" . showString fun . showId state i . showChar ',' . shows s . showString ")\n" gcodeDump state (DATA_CON s c) = showString " DW CONSTR(" . shows c . showChar ',' . shows s . showChar ',' . showChar '0' . showString ")\n" gcodeDump state (DATA_CONR s c) = showString " DW CONSTRR(" . shows c . showChar ',' . shows s . showChar ',' . showChar '0' . showString ")\n" gcodeDump state (DATA_CONT s c) = showString " DW CONSTRT(" . shows c . showChar ',' . shows s . showChar ',' . showChar '0' . showString ")\n" gcodeDump state (DATA_CONW s e) = showString " DW CONSTRW(" . shows s . showChar ',' . shows e . showString ")\n" gcodeDump state (DATA_CONP s e) = showString " DW CONSTRP(" . shows s . showChar ',' . shows e . showString ")\n" someNops :: Int -> String -> String -- DAVID someNops pad = foldr (.) id (take pad (repeat (showOp "NOP"))) someLabels :: [ Int ] -> String -> String -- DAVID someLabels cls = foldr (.) id (map (\l -> showString " JT(" . shows l . showString ")\n") cls)
(HTML for this module was generated on May 15, 2003. About the conversion tool.)